Marcos Dumay de Medeiros 8 years ago
parent
commit
ce82e0cbad

+ 2 - 2
src/System/IO/Uniform.hs

@@ -54,8 +54,8 @@ class UniformIO a where
 data SomeIO = forall a. (UniformIO a) => SomeIO a
 
 instance UniformIO SomeIO where
-  uRead (SomeIO s) n = uRead s n
-  uPut (SomeIO s) t  = uPut s t
+  uRead (SomeIO s) = uRead s
+  uPut (SomeIO s)  = uPut s
   uClose (SomeIO s) = uClose s
   startTls set (SomeIO s) = SomeIO <$> startTls set s
   isSecure (SomeIO s) = isSecure s

+ 2 - 2
src/System/IO/Uniform/ByteString.hs

@@ -29,7 +29,7 @@ instance UniformIO ByteStringIO where
       ioError $ mkIOError eofErrorType "read past end of input" Nothing Nothing
     else do
       let (r, i') = BS.splitAt n i
-      let eof' = (BS.null r && n > 0)
+      let eof' = BS.null r && n > 0
       putMVar (bsioinput s) (i', eof')
       return r
   uPut s t = do
@@ -37,7 +37,7 @@ instance UniformIO ByteStringIO where
     let o' = mappend o $ BSBuild.byteString t
     putMVar (bsiooutput s) o'
   uClose _ = return ()
-  startTls _ a = return a
+  startTls _ = return
   isSecure _ = True
 
 -- | withByteStringIO' input f

+ 4 - 4
src/System/IO/Uniform/External.hs

@@ -11,13 +11,13 @@ import System.Posix.Types (Fd(..))
 
 data Nethandler
 -- | A bounded IP port from where to accept SocketIO connections.
-newtype BoundedPort = BoundedPort {lis :: (Ptr Nethandler)}
+newtype BoundedPort = BoundedPort {lis :: Ptr Nethandler}
 data Ds
 data TlsDs
 -- | UniformIO IP connections.
-data SocketIO = SocketIO {sock :: (Ptr Ds)} | TlsSocketIO {bio :: (Ptr TlsDs)}
+data SocketIO = SocketIO {sock :: Ptr Ds} | TlsSocketIO {bio :: Ptr TlsDs}
 -- | UniformIO type for file IO.
-newtype FileIO = FileIO {fd :: (Ptr Ds)}
+newtype FileIO = FileIO {fd :: Ptr Ds}
 -- | UniformIO that reads from stdin and writes to stdout.
 data StdIO = StdIO
 
@@ -36,7 +36,7 @@ foreign import ccall interruptible "createToIPv4Host" c_connect4 :: CUInt -> CIn
 foreign import ccall interruptible "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr Ds)
 
 foreign import ccall interruptible "startSockTls" c_startSockTls :: Ptr Ds -> CString -> CString -> CString -> IO (Ptr TlsDs)
-foreign import ccall safe "getPeer" c_getPeer :: Ptr Ds -> Ptr CUInt -> Ptr CUChar -> Ptr CInt -> IO (CInt)
+foreign import ccall safe "getPeer" c_getPeer :: Ptr Ds -> Ptr CUInt -> Ptr CUChar -> Ptr CInt -> IO CInt
 
 --foreign import ccall safe "getFd" c_getFd :: Ptr Ds -> IO CInt
 --foreign import ccall safe "getTlsFd" c_getTlsFd :: Ptr TlsDs -> IO CInt

+ 15 - 18
src/System/IO/Uniform/File.hs

@@ -10,32 +10,29 @@ import Foreign
 import Foreign.C.String
 import Foreign.C.Error
 import qualified Data.ByteString as BS
+import Control.Monad
 
 import System.Posix.Types (Fd(..))
 
 
 -- | UniformIO type for file IO.
 instance UniformIO FileIO where
-  uRead s n = do
-    allocaArray n (
-      \b -> do
-        count <- c_recv (fd s) b $ fromIntegral n
-        if count < 0
-          then throwErrno "could not read"
-          else  BS.packCStringLen (b, fromIntegral count)
-      )
-  uPut s t = do
-    BS.useAsCStringLen t (
-      \(str, n) -> do
-        count <- c_send (fd s) str $ fromIntegral n
-        if count < 0
-          then throwErrno "could not write"
-          else return ()
-      )
+  uRead s n = allocaArray n (
+    \b -> do
+      count <- c_recv (fd s) b $ fromIntegral n
+      if count < 0
+        then throwErrno "could not read"
+        else  BS.packCStringLen (b, fromIntegral count)
+    )
+  uPut s t = BS.useAsCStringLen t (
+    \(str, n) -> do
+      count <- c_send (fd s) str $ fromIntegral n
+      when (count < 0) $ throwErrno "could not write"
+    )
   uClose s = do
     f <- Fd <$> c_prepareToClose (fd s)
     closeFd f
-  startTls _ f = return f
+  startTls _ = return
   isSecure _ = True
   
   
@@ -43,7 +40,7 @@ instance UniformIO FileIO where
 openFile :: String -> IO FileIO
 openFile fileName = do
   r <- withCString fileName (
-    \f -> fmap FileIO $ c_createFile f
+    fmap FileIO . c_createFile
     )
   if fd r == nullPtr
     then throwErrno "could not open file"

+ 3 - 3
src/System/IO/Uniform/HandlePair.hs

@@ -23,10 +23,10 @@ fromHandles = HandlePair
 
 -- | UniformIO that reads from stdin and writes to stdout.
 instance UniformIO HandlePair where
-  uRead (HandlePair i _) n = BS.hGetSome i n
-  uPut (HandlePair _ o) t = BS.hPut o t
+  uRead (HandlePair i _) = BS.hGetSome i
+  uPut (HandlePair _ o) = BS.hPut o
   uClose (HandlePair i o) = do
     hClose i
     hClose o
-  startTls _ a = return a
+  startTls _ = return
   isSecure _ = True

+ 28 - 35
src/System/IO/Uniform/Network.hs

@@ -20,6 +20,7 @@ import qualified Data.IP as IP
 import qualified Data.ByteString as BS
 import qualified Data.List as L
 import Control.Exception
+import Control.Monad
 import qualified Network.Socket as Soc
 import System.IO.Error
 
@@ -27,38 +28,30 @@ import System.Posix.Types (Fd(..))
 
 -- | UniformIO IP connections.
 instance UniformIO SocketIO where
-  uRead (SocketIO s) n = do
-    allocaArray n (
-      \b -> do
-        count <- c_recv s b (fromIntegral n)
-        if count < 0
-          then throwErrno "could not read"
-          else BS.packCStringLen (b, fromIntegral count)
-      )
-  uRead (TlsSocketIO s) n = do
-    allocaArray n (
-      \b -> do
-        count <- c_recvTls s b $ fromIntegral n
-        if count < 0
-          then throwErrno "could not read"
-          else BS.packCStringLen (b, fromIntegral count)
-      )
-  uPut (SocketIO s) t = do
-    BS.useAsCStringLen t (
-      \(str, n) -> do
-        count <- c_send s str $ fromIntegral n
-        if count < 0
-          then throwErrno "could not write"
-          else return ()
-      )
-  uPut (TlsSocketIO s) t = do
-    BS.useAsCStringLen t (
-      \(str, n) -> do
-        count <- c_sendTls s str $ fromIntegral n
-        if count < 0
-          then throwErrno "could not write"
-          else return ()
-      )
+  uRead (SocketIO s) n = allocaArray n (
+    \b -> do
+      count <- c_recv s b (fromIntegral n)
+      if count < 0
+        then throwErrno "could not read"
+        else BS.packCStringLen (b, fromIntegral count)
+    )
+  uRead (TlsSocketIO s) n = allocaArray n (
+    \b -> do
+      count <- c_recvTls s b $ fromIntegral n
+      if count < 0
+        then throwErrno "could not read"
+        else BS.packCStringLen (b, fromIntegral count)
+    )
+  uPut (SocketIO s) t = BS.useAsCStringLen t (
+    \(str, n) -> do
+      count <- c_send s str $ fromIntegral n
+      when (count < 0) $ throwErrno "could not write"
+    )
+  uPut (TlsSocketIO s) t = BS.useAsCStringLen t (
+    \(str, n) -> do
+      count <- c_sendTls s str $ fromIntegral n
+      when (count < 0) $ throwErrno "could not write"
+    )
   uClose (SocketIO s) = do
     f <- Fd <$> c_prepareToClose s
     closeFd f
@@ -107,8 +100,8 @@ connectToHost host port = do
 connectTo :: IP.IP -> Int -> IO SocketIO
 connectTo host port = do
   r <- case host of
-    IP.IPv4 host' -> fmap SocketIO $ c_connect4 (fromIntegral . IP.toHostAddress $ host') (fromIntegral port)
-    IP.IPv6 host' -> fmap SocketIO $ withArray (ipToArray host') (
+    IP.IPv4 host' -> SocketIO <$> c_connect4 (fromIntegral . IP.toHostAddress $ host') (fromIntegral port)
+    IP.IPv6 host' -> SocketIO <$> withArray (ipToArray host') (
       \add -> c_connect6 add (fromIntegral port)
       )
   if sock r == nullPtr
@@ -145,7 +138,7 @@ bindPort port = do
 --  Accept clients on a port previously bound with bindPort.
 accept :: BoundedPort -> IO SocketIO
 accept port = do
-  r <- fmap SocketIO $ c_accept (lis port)
+  r <- SocketIO <$> c_accept (lis port)
   if sock r == nullPtr
     then throwErrno "could not accept connection"
     else return r

+ 14 - 17
src/System/IO/Uniform/Std.hs

@@ -8,25 +8,22 @@ import System.IO.Uniform.External
 import Foreign
 import Foreign.C.Error
 import qualified Data.ByteString as BS
+import Control.Monad
 
 -- | UniformIO that reads from stdin and writes to stdout.
 instance UniformIO StdIO where
-  uRead _ n = do
-    allocaArray n (
-      \b -> do
-        count <- c_recvStd b (fromIntegral n)
-        if count < 0
-          then throwErrno "could not read"
-          else BS.packCStringLen (b, fromIntegral count)
-      )
-  uPut _ t = do
-    BS.useAsCStringLen t (
-      \(str, n) -> do
-        count <- c_sendStd str $ fromIntegral n
-        if count < 0
-          then throwErrno "could not write"
-          else return ()
-      )
+  uRead _ n = allocaArray n (
+    \b -> do
+      count <- c_recvStd b (fromIntegral n)
+      if count < 0
+        then throwErrno "could not read"
+        else BS.packCStringLen (b, fromIntegral count)
+    )
+  uPut _ t = BS.useAsCStringLen t (
+    \(str, n) -> do
+      count <- c_sendStd str $ fromIntegral n
+      when (count < 0) $ throwErrno "could not write"
+    )
   uClose _ = return ()
-  startTls _ a = return a
+  startTls _ = return
   isSecure _ = True

+ 14 - 84
src/System/IO/Uniform/Streamline.hs

@@ -35,9 +35,6 @@ module System.IO.Uniform.Streamline (
   scan',
   recieveTill,
   recieveTill',
-  -- ** Deprecated functions
-  lazyRecieveLine,
-  lazyRecieveN,
   -- * Behavior settings
   startTls,
   isSecure,
@@ -63,7 +60,6 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import Data.Word8 (Word8)
 import Data.IP (IP)
-import qualified Data.Char as C
 
 import qualified Data.Attoparsec.ByteString as A
 
@@ -184,7 +180,7 @@ send r = Streamline $ \cl -> do
 send' :: MonadIO m => LBS.ByteString -> Streamline m ()
 send' r = Streamline $ \cl -> do
   let dd = LBS.toChunks r
-  mapM (writeF cl) dd
+  mapM_ (writeF cl) dd
   return ((), cl)
 
 {- |
@@ -254,29 +250,6 @@ recieveLine = recieveTill "\n"
 recieveLine' :: MonadIO m => Streamline m LBS.ByteString
 recieveLine' = recieveTill' "\n"
 
--- | Use recieveLine'.
-lazyRecieveLine :: MonadIO m => Streamline m [ByteString]
-{-# DEPRECATED #-}
-lazyRecieveLine = Streamline $ \cl -> lazyRecieveLine' cl
-  where
-    lazyRecieveLine' :: MonadIO m => StreamlineState -> m ([ByteString], StreamlineState)
-    lazyRecieveLine' cl' = 
-      if isEOF cl'
-      then eofError "System.IO.Uniform.Streamline.lazyRecieveLine"
-      else
-        if BS.null $ buff cl'
-        then do
-          dt <- readF cl'
-          lazyRecieveLine' cl'{buff=dt}{isEOF=BS.null dt}
-        else do
-          let l = A.parseOnly lineWithEol $ buff cl'
-          case l of
-            Left _ -> do
-              l' <- readF cl'
-              (ret, cl'') <- lazyRecieveLine' cl'{buff=l'}{isEOF=BS.null l'}
-              return ((buff cl') : ret, cl'')
-            Right (ret, dt) -> return ([ret], cl'{buff=dt})
-
 -- | Recieves the given number of bytes.
 recieveN :: MonadIO m => Int -> Streamline m ByteString
 recieveN n = LBS.toStrict <$> recieveN' n
@@ -290,7 +263,7 @@ recieveN' n | n <= 0 = return ""
               return (LBS.fromChunks tt, cl')
   where
     recieve d b
-      | isEOF d = eofError "System.IO.Uniform.Streamline.lazyRecieveN"
+      | isEOF d = eofError "System.IO.Uniform.Streamline.recieveN"
       | BS.null . buff $ d = do
         dt <- readF d
         recieve d{buff=dt}{isEOF=BS.null dt} b
@@ -301,35 +274,6 @@ recieveN' n | n <= 0 = return ""
         (r, d') <- recieve d{buff=""} $ b - (BS.length . buff $ d)
         return (buff d : r, d')
 
--- | Use recieveN'.
-lazyRecieveN :: (Functor m, MonadIO m) => Int -> Streamline m [ByteString]
-{-# DEPRECATED #-}
-lazyRecieveN n' = Streamline $ \cl' -> lazyRecieveN' cl' n'
-  where
-    lazyRecieveN' :: (Functor m, MonadIO m) => StreamlineState -> Int -> m ([ByteString], StreamlineState)
-    lazyRecieveN' cl n =
-      if isEOF cl
-      then eofError "System.IO.Uniform.Streamline.lazyRecieveN"
-      else
-        if BS.null (buff cl)
-        then do
-          b <- readF cl
-          let eof = BS.null b
-          let cl' = cl{buff=b}{isEOF=eof}
-          lazyRecieveN' cl' n
-        else
-          if n <= BS.length (buff cl)
-          then let
-            ret = [BS.take n (buff cl)]
-            buff' = BS.drop n (buff cl)
-            in return (ret, cl{buff=buff'})
-          else let
-            cl' = cl{buff=""}
-            b = buff cl
-            in fmap (appFst b) $ lazyRecieveN' cl' (n - BS.length b)
-    appFst :: a -> ([a], b) -> ([a], b)
-    appFst a (l, b) = (a:l, b)
-
 -- | Recieves data until it matches the argument.
 --   Returns all of it, including the matching data.
 recieveTill :: MonadIO m => ByteString -> Streamline m ByteString
@@ -337,7 +281,7 @@ recieveTill t = LBS.toStrict <$> recieveTill' t
 
 -- | Lazy version of recieveTill
 recieveTill' :: MonadIO m => ByteString -> Streamline m LBS.ByteString
-recieveTill' t = recieve . BS.unpack $ t
+recieveTill' = recieve . BS.unpack
   where
     recieve t' = scan' [] (textScanner t')
 
@@ -360,7 +304,7 @@ runAttoparsecAndReturn p = Streamline $ \cl ->
     (cl', i, a) <- liftIO $ continueResult cl c
     return ((i, a), cl')
   where
-    continueResult :: StreamlineState -> A.Result a -> IO (StreamlineState, ByteString, (Either String a))
+    continueResult :: StreamlineState -> A.Result a -> IO (StreamlineState, ByteString, Either String a)
     -- tx eof ds 
     continueResult cl c = case c of
       A.Fail i _ msg -> return (cl{buff=i}, BS.take (BS.length (buff cl) - BS.length i) (buff cl), Left msg)
@@ -381,7 +325,7 @@ runAttoparsec p = Streamline $ \cl ->
     (cl', a) <- liftIO $ continueResult cl c
     return (a, cl')
   where
-    continueResult :: StreamlineState -> A.Result a -> IO (StreamlineState, (Either String a))
+    continueResult :: StreamlineState -> A.Result a -> IO (StreamlineState, Either String a)
     continueResult cl c = case c of
         A.Fail i _ msg -> return (cl{buff=i}, Left msg)
         A.Done i r -> return (cl{buff=i}, Right r)
@@ -418,38 +362,24 @@ Setting to Nothing will disable echo.
 echoTo :: Monad m => Maybe Handle -> Streamline m ()
 echoTo h = Streamline $ \cl -> return ((), cl{echo=h})
 
-lineWithEol :: A.Parser (ByteString, ByteString)
-lineWithEol = do
-  l <- A.scan False lineScanner
-  r <- A.takeByteString
-  return (l, r)
-  
 eofError :: MonadIO m => String -> m a
 eofError msg = liftIO . ioError $ mkIOError eofErrorType msg Nothing Nothing
 
-lineScanner :: Bool -> Word8 -> Maybe Bool
-lineScanner False c 
-  | c == (fromIntegral . C.ord $ '\n') = Just True
-  | otherwise = Just False
-lineScanner True _ = Nothing
-
 {- |
 Closes the target of a streamline state, releasing any used resource.
 -}
 close :: MonadIO m => StreamlineState -> m ()
-close st = liftIO . S.uClose . str $ st
+close = liftIO . S.uClose . str
 
 {- |
 Retrieves the remaining contents of a streamline state, closing it afterwards.
 -}
 remaining :: MonadIO m => StreamlineState -> m LBS.ByteString
-remaining st =
-  if isEOF st then close st >> return LBS.empty
-  else
-    if BS.null . buff $ st
-    then do
-      dt <- readF st
-      remaining st{buff=dt}{isEOF=BS.null dt}
-    else do
-      dt' <- remaining st{buff=BS.empty}
-      return $ LBS.append (LBS.fromStrict . buff $ st) dt'
+remaining st
+  | isEOF st = close st >> return LBS.empty
+  | BS.null . buff $ st = do
+    dt <- readF st
+    remaining st{buff=dt}{isEOF=BS.null dt}
+  | otherwise = do
+    dt' <- remaining st{buff=BS.empty}
+    return $ LBS.append (LBS.fromStrict . buff $ st) dt'

+ 4 - 4
src/System/IO/Uniform/Streamline/Scanner.hs

@@ -29,7 +29,7 @@ instance Functor IOScannerState where
   fmap f (LastPass x) = LastPass $ f x
   fmap f (Running x) = Running $ f x
 instance Applicative IOScannerState where
-  pure a = Running a
+  pure = Running
   Finished <*> _ = Finished
   _ <*> Finished = Finished
   (LastPass f) <*> (LastPass x) = LastPass $ f x
@@ -63,7 +63,7 @@ anyScanner scanners = scan
 Given a sequence of bytes, creates a scanner that will scan
 its input untill that sequence is found.
 -}
-textScanner :: [Word8] -> (IOScanner [[Word8]])
+textScanner :: [Word8] -> IOScanner [[Word8]]
 textScanner [] = \_ _ -> Finished
 textScanner t@(c:_) = scanner
   where
@@ -76,8 +76,8 @@ textScanner t@(c:_) = scanner
     popStacks ((h':hh):ss) h
       | h == h' && null hh = case popStacks ss h of
         Finished -> Finished
-        LastPass ss' -> LastPass $ ss'
-        Running ss' -> LastPass $ ss'
+        LastPass ss' -> LastPass ss'
+        Running ss' -> LastPass ss'
       | h == h' = case popStacks ss h of
         Finished -> Finished
         LastPass ss' -> LastPass $ hh:ss'

+ 1 - 5
test/Blocking.hs

@@ -18,15 +18,11 @@ import qualified Data.Attoparsec.ByteString as A
 tests :: IO [Test]
 tests = return [
   simpleTest "recieveLine"
-  (successTimeout "A test\n" (S.recieveLine)),
+  (successTimeout "A test\n" S.recieveLine),
   simpleTest "runAttoparsec with successful parser"
   (successTimeout "abcde" (parseBS (A.string "abcde"))),
   simpleTest "runAttoparsec with failed parser"
   (failTimeout "abcde" (parseBS (A.string "c"))),
-  simpleTest "lazyRecieveLine"
-  (successTimeout "Another test\n" (concatLine S.lazyRecieveLine)),
-  simpleTest "lazyReceiveN"
-  (failTimeout "abcde" (concatLine (S.lazyRecieveN 5))),
   simpleTest "recieveTill"
   (failTimeout "abcde" (restoreLine $ S.recieveTill "de"))
   ]