|
@@ -3,7 +3,33 @@
|
|
|
|
|
|
|
|
|
|
|
|
-module System.IO.Uniform.Streamline (Streamline, withClient, withServer, withTarget, send, send', receiveLine, lazyRecieveLine, lazyReceiveN, startTls, runAttoparsec, runAttoparsecAndReturn, isSecure, setTimeout, setEcho) where
|
|
|
+module System.IO.Uniform.Streamline (
|
|
|
+ Streamline,
|
|
|
+ IOScannerState,
|
|
|
+ withClient,
|
|
|
+ withServer,
|
|
|
+ withTarget,
|
|
|
+ send,
|
|
|
+ send',
|
|
|
+ recieveLine,
|
|
|
+ recieveLine',
|
|
|
+ lazyRecieveLine,
|
|
|
+ recieveN,
|
|
|
+ recieveN',
|
|
|
+ lazyRecieveN,
|
|
|
+ recieveTill,
|
|
|
+ recieveTill',
|
|
|
+ startTls,
|
|
|
+ runAttoparsec,
|
|
|
+ runAttoparsecAndReturn,
|
|
|
+ isSecure,
|
|
|
+ setTimeout,
|
|
|
+ setEcho,
|
|
|
+ runScanner,
|
|
|
+ runScanner',
|
|
|
+ scan,
|
|
|
+ scan'
|
|
|
+ ) where
|
|
|
|
|
|
import qualified System.IO.Uniform as S
|
|
|
import qualified System.IO.Uniform.Network as N
|
|
@@ -19,6 +45,7 @@ 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
|
|
|
|
|
@@ -51,8 +78,8 @@ writeF cl l = if echo cl
|
|
|
|
|
|
|
|
|
|
|
|
-withServer :: MonadIO m => Streamline m a -> IP -> Int -> m a
|
|
|
-withServer f host port = do
|
|
|
+withServer :: MonadIO m => IP -> Int -> Streamline m a -> m a
|
|
|
+withServer host port f = do
|
|
|
ds <- liftIO $ N.connectTo host port
|
|
|
(ret, _) <- withTarget' f $ Data (SomeIO ds) defaultTimeout "" False False
|
|
|
liftIO $ S.uClose ds
|
|
@@ -61,8 +88,8 @@ withServer f host port = do
|
|
|
|
|
|
|
|
|
|
|
|
-withClient :: MonadIO m => (IP -> Int -> Streamline m a) -> N.BoundedPort -> m a
|
|
|
-withClient f port = do
|
|
|
+withClient :: MonadIO m => N.BoundedPort -> (IP -> Int -> Streamline m a) -> m a
|
|
|
+withClient port f = do
|
|
|
ds <- liftIO $ N.accept port
|
|
|
(peerIp, peerPort) <- liftIO $ N.getPeer ds
|
|
|
(ret, _) <- withTarget' (f peerIp peerPort) $ Data (SomeIO ds) defaultTimeout "" False False
|
|
@@ -72,8 +99,8 @@ withClient f port = do
|
|
|
|
|
|
|
|
|
|
|
|
-withTarget :: (MonadIO m, UniformIO a) => Streamline m b -> a -> m b
|
|
|
-withTarget f s = do
|
|
|
+withTarget :: (MonadIO m, UniformIO a) => a -> Streamline m b -> m b
|
|
|
+withTarget s f = do
|
|
|
(ret, _) <- withTarget' f $ Data (SomeIO s) defaultTimeout "" False False
|
|
|
return ret
|
|
|
|
|
@@ -117,57 +144,151 @@ send' r = Streamline $ \cl -> do
|
|
|
mapM (writeF cl) dd
|
|
|
return ((), cl)
|
|
|
|
|
|
|
|
|
-receiveLine :: MonadIO m => Streamline m ByteString
|
|
|
-receiveLine = do
|
|
|
- l <- runAttoparsec parseLine
|
|
|
- case l of
|
|
|
- Left _ -> return ""
|
|
|
- Right l' -> return l'
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+data IOScannerState a =
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+ Finished |
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+ LastPass a |
|
|
|
+
|
|
|
+
|
|
|
+ Running a
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+runScanner :: MonadIO m => s -> (s -> Word8 -> IOScannerState s) -> Streamline m (ByteString, s)
|
|
|
+runScanner state scanner = do
|
|
|
+ (rt, st) <- runScanner' state scanner
|
|
|
+ return (LBS.toStrict rt, st)
|
|
|
+
|
|
|
+
|
|
|
+Very much like Attoparsec's runScanner:
|
|
|
+
|
|
|
+runScanner' scanner initial_state
|
|
|
+
|
|
|
+Recieves data, running the scanner on each byte,
|
|
|
+using the scanner result as initial state for the
|
|
|
+next byte, and stopping when the scanner returns
|
|
|
+Nothing.
|
|
|
+
|
|
|
+Returns the scanned ByteString.
|
|
|
+ -}
|
|
|
+runScanner' :: MonadIO m => s -> (s -> Word8 -> IOScannerState s) -> Streamline m (LBS.ByteString, s)
|
|
|
+runScanner' state scanner = Streamline $ \d ->
|
|
|
+ do
|
|
|
+ (tx, st, d') <- in_scan d state
|
|
|
+ return ((LBS.fromChunks tx, st), d')
|
|
|
+ where
|
|
|
+
|
|
|
+ in_scan d st
|
|
|
+ | isEOF d = eofError "System.IO.Uniform.Streamline.scan'"
|
|
|
+ | BS.null (buff d) = do
|
|
|
+ dt <- readF d
|
|
|
+ if BS.null dt
|
|
|
+ then return ([], st, d{isEOF=True})
|
|
|
+ else in_scan d{buff=dt} st
|
|
|
+ | otherwise = case sscan scanner st 0 (BS.unpack . buff $ d) of
|
|
|
+ AllInput st' -> do
|
|
|
+ (tx', st'', d') <- in_scan d{buff=""} st'
|
|
|
+ return (buff d:tx', st'', d')
|
|
|
+ SplitAt n st' -> let
|
|
|
+ (r, i) = BS.splitAt n (buff d)
|
|
|
+ in return ([r], st', d{buff=i})
|
|
|
+
|
|
|
+ sscan :: (s -> Word8 -> IOScannerState s) -> s -> Int -> [Word8] -> ScanResult s
|
|
|
+ sscan _ s0 _ [] = AllInput s0
|
|
|
+ sscan s s0 i (w:ww) = case s s0 w of
|
|
|
+ Finished -> SplitAt i s0
|
|
|
+ LastPass s1 -> SplitAt (i+1) s1
|
|
|
+ Running s1 -> sscan s s1 (i+1) ww
|
|
|
+
|
|
|
+data ScanResult s = SplitAt Int s | AllInput s
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+scan :: MonadIO m => s -> (s -> Word8 -> IOScannerState s) -> Streamline m ByteString
|
|
|
+scan state scanner = fst <$> runScanner state scanner
|
|
|
+
|
|
|
+
|
|
|
+scan' :: MonadIO m => s -> (s -> Word8 -> IOScannerState s) -> Streamline m LBS.ByteString
|
|
|
+scan' state scanner = fst <$> runScanner' state scanner
|
|
|
+
|
|
|
+
|
|
|
+recieveLine :: MonadIO m => Streamline m ByteString
|
|
|
+recieveLine = recieveTill "\n"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
+
|
|
|
+recieveLine' :: MonadIO m => Streamline m LBS.ByteString
|
|
|
+recieveLine' = recieveTill' "\n"
|
|
|
+
|
|
|
+
|
|
|
lazyRecieveLine :: MonadIO m => Streamline m [ByteString]
|
|
|
-lazyRecieveLine = Streamline $ \cl -> lazyReceiveLine' cl
|
|
|
+{-# DEPRECATED #-}
|
|
|
+lazyRecieveLine = Streamline $ \cl -> lazyRecieveLine' cl
|
|
|
where
|
|
|
- lazyReceiveLine' :: MonadIO m => Data -> m ([ByteString], Data)
|
|
|
- lazyReceiveLine' cl' =
|
|
|
+ lazyRecieveLine' :: MonadIO m => Data -> m ([ByteString], Data)
|
|
|
+ lazyRecieveLine' cl' =
|
|
|
if isEOF cl'
|
|
|
- then eofError "System.IO.Uniform.Streamline.lazyReceiveLine"
|
|
|
+ then eofError "System.IO.Uniform.Streamline.lazyRecieveLine"
|
|
|
else
|
|
|
if BS.null $ buff cl'
|
|
|
then do
|
|
|
dt <- readF cl'
|
|
|
- lazyReceiveLine' cl'{buff=dt}{isEOF=BS.null dt}
|
|
|
+ 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'') <- lazyReceiveLine' cl'{buff=l'}{isEOF=BS.null l'}
|
|
|
+ (ret, cl'') <- lazyRecieveLine' cl'{buff=l'}{isEOF=BS.null l'}
|
|
|
return ((buff cl') : ret, cl'')
|
|
|
Right (ret, dt) -> return ([ret], cl'{buff=dt})
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-lazyReceiveN :: (Functor m, MonadIO m) => Int -> Streamline m [ByteString]
|
|
|
-lazyReceiveN n' = Streamline $ \cl' -> lazyReceiveN' cl' n'
|
|
|
+
|
|
|
+recieveN :: MonadIO m => Int -> Streamline m ByteString
|
|
|
+recieveN n = LBS.toStrict <$> recieveN' n
|
|
|
+
|
|
|
+
|
|
|
+recieveN' :: MonadIO m => Int -> Streamline m LBS.ByteString
|
|
|
+recieveN' n = Streamline $ \cl ->
|
|
|
+ do
|
|
|
+ (tt, cl') <- recieve cl n
|
|
|
+ return (LBS.fromChunks tt, cl')
|
|
|
+ where
|
|
|
+ recieve d b
|
|
|
+ | isEOF d = eofError "System.IO.Uniform.Streamline.lazyRecieveN"
|
|
|
+ | BS.null . buff $ d = do
|
|
|
+ dt <- readF d
|
|
|
+ recieve d{buff=dt}{isEOF=BS.null dt} b
|
|
|
+ | b <= (BS.length . buff $ d) = let
|
|
|
+ (r, dt) = BS.splitAt b $ buff d
|
|
|
+ in return ([r], d{buff=dt})
|
|
|
+ | otherwise = do
|
|
|
+ (r, d') <- recieve d{buff=""} $ b - (BS.length . buff $ d)
|
|
|
+ return (buff d : r, d')
|
|
|
+
|
|
|
+
|
|
|
+lazyRecieveN :: (Functor m, MonadIO m) => Int -> Streamline m [ByteString]
|
|
|
+{-# DEPRECATED #-}
|
|
|
+lazyRecieveN n' = Streamline $ \cl' -> lazyRecieveN' cl' n'
|
|
|
where
|
|
|
- lazyReceiveN' :: (Functor m, MonadIO m) => Data -> Int -> m ([ByteString], Data)
|
|
|
- lazyReceiveN' cl n =
|
|
|
+ lazyRecieveN' :: (Functor m, MonadIO m) => Data -> Int -> m ([ByteString], Data)
|
|
|
+ lazyRecieveN' cl n =
|
|
|
if isEOF cl
|
|
|
- then eofError "System.IO.Uniform.Streamline.lazyReceiveN"
|
|
|
+ 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}
|
|
|
- lazyReceiveN' cl' n
|
|
|
+ lazyRecieveN' cl' n
|
|
|
else
|
|
|
if n <= BS.length (buff cl)
|
|
|
then let
|
|
@@ -177,10 +298,21 @@ lazyReceiveN n' = Streamline $ \cl' -> lazyReceiveN' cl' n'
|
|
|
else let
|
|
|
cl' = cl{buff=""}
|
|
|
b = buff cl
|
|
|
- in fmap (appFst b) $ lazyReceiveN' cl' (n - BS.length b)
|
|
|
+ in fmap (appFst b) $ lazyRecieveN' cl' (n - BS.length b)
|
|
|
appFst :: a -> ([a], b) -> ([a], b)
|
|
|
appFst a (l, b) = (a:l, b)
|
|
|
|
|
|
+
|
|
|
+
|
|
|
+recieveTill :: MonadIO m => ByteString -> Streamline m ByteString
|
|
|
+recieveTill t = LBS.toStrict <$> recieveTill' t
|
|
|
+
|
|
|
+
|
|
|
+recieveTill' :: MonadIO m => ByteString -> Streamline m LBS.ByteString
|
|
|
+recieveTill' t = recieve . BS.unpack $ t
|
|
|
+ where
|
|
|
+ recieve t' = scan' [] (textScanner t')
|
|
|
+
|
|
|
|
|
|
|
|
|
startTls :: MonadIO m => TlsSettings -> Streamline m ()
|
|
@@ -245,12 +377,6 @@ setTimeout t = Streamline $ \cl -> return ((), cl{timeout=t})
|
|
|
setEcho :: Monad m => Bool -> Streamline m ()
|
|
|
setEcho e = Streamline $ \cl -> return ((), cl{echo=e})
|
|
|
|
|
|
-parseLine :: A.Parser ByteString
|
|
|
-parseLine = do
|
|
|
- l <- A.takeTill isEol
|
|
|
- (A.word8 13 >> A.word8 10) <|> A.word8 10
|
|
|
- return l
|
|
|
-
|
|
|
lineWithEol :: A.Parser (ByteString, ByteString)
|
|
|
lineWithEol = do
|
|
|
l <- A.scan False lineScanner
|
|
@@ -258,11 +384,31 @@ lineWithEol = do
|
|
|
return (l, r)
|
|
|
|
|
|
lineScanner :: Bool -> Word8 -> Maybe Bool
|
|
|
-lineScanner False c = Just $ isEol c
|
|
|
-lineScanner True c = if isEol c then Just True else Nothing
|
|
|
-
|
|
|
-isEol :: Word8 -> Bool
|
|
|
-isEol c = c == 13 || c == 10
|
|
|
+lineScanner False c
|
|
|
+ | c == (fromIntegral . C.ord $ '\n') = Just True
|
|
|
+ | otherwise = Just False
|
|
|
+lineScanner True _ = Nothing
|
|
|
|
|
|
eofError :: MonadIO m => String -> m a
|
|
|
eofError msg = liftIO . ioError $ mkIOError eofErrorType msg Nothing Nothing
|
|
|
+
|
|
|
+textScanner :: [Word8] -> ([[Word8]] -> Word8 -> IOScannerState [[Word8]])
|
|
|
+textScanner [] = \_ _ -> Finished
|
|
|
+textScanner t@(c:_) = scanner
|
|
|
+ where
|
|
|
+ scanner st c'
|
|
|
+ | c == c' = popStacks c' $ t:st
|
|
|
+ | otherwise = popStacks c' st
|
|
|
+ popStacks :: Word8 -> [[Word8]] -> IOScannerState [[Word8]]
|
|
|
+ popStacks _ [] = Running []
|
|
|
+ popStacks _ ([]:_) = Finished
|
|
|
+ popStacks h ((h':hh):ss)
|
|
|
+ | h == h' && null hh = case popStacks h ss of
|
|
|
+ Finished -> Finished
|
|
|
+ LastPass ss' -> LastPass $ ss'
|
|
|
+ Running ss' -> LastPass $ ss'
|
|
|
+ | h == h' = case popStacks h ss of
|
|
|
+ Finished -> Finished
|
|
|
+ LastPass ss' -> LastPass $ hh:ss'
|
|
|
+ Running ss' -> Running $ hh:ss'
|
|
|
+ | otherwise = popStacks h ss
|