module Data.IterIO.ListLike
(
putI, sendI
, headLI, safeHeadLI
, headI, safeHeadI
, lineI, safeLineI
, dataMaxI, data0MaxI, takeI
, handleI, sockDgramI, sockStreamI
, stdoutI
, SeekMode(..)
, SizeC(..), SeekC(..), TellC(..), fileCtl
, GetSocketC(..), socketCtl
, enumDgram, enumDgramFrom, enumStream
, enumHandle, enumHandle', enumNonBinHandle
, enumFile, enumFile'
, enumStdin
, inumMax, inumTakeExact
, inumLog, inumhLog, inumStderr
, inumLtoS, inumStoL
, pairFinalizer, iterHandle, iterStream
) where
import Prelude hiding (null)
import Control.Concurrent
import Control.Exception (onException)
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L
(defaultChunkSize, chunk, ByteString(..))
import Data.Char
import Data.Monoid
import Data.Typeable
import Network.Socket
import System.IO
import qualified Data.ListLike as LL
import Data.IterIO.Iter
import Data.IterIO.Inum
import Data.IterIO.Extra
echr :: (Enum e) => Char -> e
echr = toEnum . ord
putI :: (ChunkData t, Monad m) =>
(t -> Iter t m a)
-> Iter t m b
-> Iter t m ()
putI putfn eoffn = doput `finallyI` eoffn
where doput = do Chunk t eof <- chunkI
unless (null t) $ putfn t >> return ()
if eof then return () else doput
sendI :: (Show t, Monad m) =>
(t -> Iter [t] m a)
-> Iter [t] m ()
sendI sendfn = do
dgram <- safeHeadI
case dgram of
Just pkt -> sendfn pkt >> sendI sendfn
Nothing -> return ()
headLI :: (Show a, Monad m) => Iter [a] m a
headLI = iterF dohead
where dohead (Chunk (a:as) eof) = Done a $ Chunk as eof
dohead c = Fail err Nothing $ Just c
err = mkIterEOF "headLI"
safeHeadLI :: (Show a, Monad m) => Iter [a] m (Maybe a)
safeHeadLI = iterF $ dohead
where dohead (Chunk (a:as) eof) = Done (Just a) $ Chunk as eof
dohead _ = Done Nothing chunkEOF
headI :: (ChunkData t, LL.ListLike t e, Monad m) => Iter t m e
headI = iterF $ \c@(Chunk t eof) ->
if LL.null t then Fail err Nothing $ Just c
else Done (LL.head t) $ Chunk (LL.tail t) eof
where err = mkIterEOF "headI"
safeHeadI :: (ChunkData t, LL.ListLike t e, Monad m) => Iter t m (Maybe e)
safeHeadI = iterF $ \c@(Chunk t eof) ->
if LL.null t then Done Nothing c
else Done (Just $ LL.head t) $ Chunk (LL.tail t) eof
safeLineI :: (ChunkData t, Monad m, LL.ListLike t e, Eq t, Enum e, Eq e) =>
Iter t m (Maybe t)
safeLineI = iterF $ doline LL.empty
where
cr = LL.singleton $ echr '\r'
nl = LL.singleton $ echr '\n'
crnl = LL.append cr nl
eol c = c == echr '\n' || c == echr '\r'
doline acc (Chunk t eof) =
let acc' = LL.append acc t
(l, r) = LL.break eol acc'
result = dolr eof l r
in case result of
Just (l', r') -> Done (Just l') (Chunk r' eof)
Nothing | eof -> Done Nothing (Chunk acc' True)
_ -> IterF $ iterF $ doline acc'
dolr eof l r
| LL.isPrefixOf nl r = Just (l, LL.drop (LL.length nl) r)
| LL.isPrefixOf crnl r = Just (l, LL.drop (LL.length crnl) r)
| LL.isPrefixOf cr r && (eof || r /= cr) =
Just (l, LL.drop (LL.length cr) r)
| otherwise = Nothing
lineI :: (Monad m, ChunkData t, LL.ListLike t e, Eq t, Enum e, Eq e) =>
Iter t m t
lineI = do
mline <- safeLineI
case mline of
Nothing -> throwEOFI "lineI"
Just line -> return line
data0MaxI :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Iter t m t
data0MaxI maxlen | maxlen <= 0 = return mempty
| otherwise = iterF $ \(Chunk s eof) ->
case LL.splitAt maxlen s of
(h, t) -> Done h $ Chunk t eof
dataMaxI :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Iter t m t
dataMaxI maxlen | maxlen <= 0 = return mempty
| otherwise = iterF $ \c@(Chunk s eof) ->
if LL.null s then Fail err Nothing $ Just c
else case LL.splitAt maxlen s of
(h, t) -> Done h $ Chunk t eof
where err = mkIterEOF "dataMaxI"
takeI :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Iter t m t
takeI len | len <= 0 = return mempty
| otherwise = do
t <- data0MaxI len
let tlen = LL.length t
if tlen == len || tlen == 0
then return t
else LL.append t `liftM` takeI (len tlen)
handleI :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
Handle
-> Iter t m ()
handleI h = putI (liftIO . LL.hPutStr h) (liftIO $ hShutdown h 1)
sockDgramI :: (MonadIO m, SendRecvString t) =>
Socket
-> Maybe SockAddr
-> Iter [t] m ()
sockDgramI s mdest = loop
where sendit = case mdest of Nothing -> liftIO . genSend s
Just dest -> liftIO . flip (genSendTo s) dest
loop = safeHeadI >>= maybe (return ()) (\str -> sendit str >> loop)
sockStreamI :: (ChunkData t, SendRecvString t, MonadIO m) =>
Socket -> Iter t m ()
sockStreamI sock = putI (liftIO . genSend sock)
(liftIO $ shutdown sock ShutdownSend)
stdoutI :: (LL.ListLikeIO t e, ChunkData t, MonadIO m) => Iter t m ()
stdoutI = putI (liftIO . LL.hPutStr stdout) (return ())
data SizeC = SizeC deriving (Typeable)
instance CtlCmd SizeC Integer
data SeekC = SeekC !SeekMode !Integer deriving (Typeable)
instance CtlCmd SeekC ()
data TellC = TellC deriving (Typeable)
instance CtlCmd TellC Integer
fileCtl :: (ChunkData t, LL.ListLike t e, MonadIO m) =>
Handle
-> CtlHandler (Iter () m) t m a
fileCtl h = (mkFlushCtl $ \(SeekC mode pos) -> liftIO (hSeek h mode pos))
`consCtl` tryTellC
`consCtl` (mkCtl $ \SizeC -> liftIO (hFileSize h))
`consCtl` passCtl id
where tryTellC TellC n c@(Chunk t _) = do
offset <- liftIO $ hTell h
return $ runIter (n $ offset LL.genericLength t) c
data GetSocketC = GetSocketC deriving (Typeable)
instance CtlCmd GetSocketC Socket
socketCtl :: (ChunkData t, MonadIO m) =>
Socket -> CtlHandler (Iter () m) t m a
socketCtl s = (mkCtl $ \GetSocketC -> return s)
`consCtl` passCtl id
enumDgram :: (MonadIO m, SendRecvString t) =>
Socket
-> Onum [t] m a
enumDgram sock = mkInumC id (socketCtl sock) $
liftIO $ liftM (: []) $ genRecv sock 0x10000
enumDgramFrom :: (MonadIO m, SendRecvString t) =>
Socket
-> Onum [(t, SockAddr)] m a
enumDgramFrom sock = mkInumC id (socketCtl sock) $
liftIO $ liftM (: []) $ genRecvFrom sock 0x10000
enumStream :: (MonadIO m, ChunkData t, SendRecvString t) =>
Socket -> Onum t m a
enumStream sock = mkInumC id (socketCtl sock) $
liftIO (genRecv sock L.defaultChunkSize)
enumHandle' :: (MonadIO m) => Handle -> Onum L.ByteString m a
enumHandle' = enumHandle
enumHandle :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
Handle
-> Onum t m a
enumHandle h iter = tryFI (liftIO $ hSetBinaryMode h True) >>= check
where check (Left e) = Iter $ Fail e (Just $ IterF iter) . Just
check (Right _) = enumNonBinHandle h iter
enumNonBinHandle :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
Handle
-> Onum t m a
enumNonBinHandle h =
mkInumC id (fileCtl h) $
liftIO (hWaitForInput h (1) >> LL.hGetNonBlocking h L.defaultChunkSize)
enumFile' :: (MonadIO m) => FilePath -> Onum L.ByteString m a
enumFile' = enumFile
enumFile :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
FilePath -> Onum t m a
enumFile path = inumBracket (liftIO $ openBinaryFile path ReadMode)
(liftIO . hClose) enumNonBinHandle
enumStdin :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => Onum t m a
enumStdin = enumHandle stdin
inumTakeExact :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Inum t t m a
inumTakeExact = mkInumM . loop
where loop n | n <= 0 = return ()
| otherwise = do
t <- dataI
let (h, r) = LL.splitAt n t
ungetI r
_ <- ifeed h
loop $ n LL.length h
inumMax :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Inum t t m a
inumMax n0 i | n0 <= 0 = runner i mempty
| otherwise = do
(t, more) <- next n0
r <- runner i $ chunk t
case r of
IterF i1 | more -> inumMax (n0 LL.length t) i1
_ | isIterActive r -> return r
_ -> case getResid r of
Chunk t1 _ -> ungetI t1 >> return (setResid r mempty)
where runner = runIterMC (passCtl pullupResid)
next n = Iter $ \(Chunk t eof) ->
case LL.splitAt n t of
(t1, t2) -> Done (t1, not eof && LL.null t2) (Chunk t2 eof)
inumLog :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
FilePath
-> Bool
-> Inum t t m a
inumLog path trunc = inumBracket openLog (liftIO . hClose) inumhLog
where openLog = liftIO $ do
h <- openBinaryFile path (if trunc then WriteMode else AppendMode)
hSetBuffering h NoBuffering
return h
inumhLog :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
Handle -> Inum t t m a
inumhLog h = mkInumP pullupResid $ do
buf <- data0I
unless (null buf) $ liftIO $ LL.hPutStr h buf
return buf
inumStderr :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) =>
Inum t t m a
inumStderr = inumhLog stderr
inumLtoS :: (Monad m) => Inum L.ByteString S.ByteString m a
inumLtoS = mkInumP rh loop
where rh (a, b) = (L.chunk b a, S.empty)
loop = iterF $ \c@(Chunk lbs eof) ->
case lbs of
L.Chunk bs rest -> Done bs (Chunk rest eof)
_ -> Done S.empty c
inumStoL :: (Monad m) => Inum S.ByteString L.ByteString m a
inumStoL = mkInumP rh loop
where rh (a, b) = (S.concat (L.toChunks b ++ [a]), L.empty)
loop = iterF $ \(Chunk bs eof) ->
Done (L.chunk bs L.Empty) (Chunk S.empty eof)
pairFinalizer :: (ChunkData t, ChunkData t1, ChunkData t2
, MonadIO m, MonadIO m1) =>
Iter t m a
-> Inum t1 t2 m1 b
-> IO ()
-> IO (Iter t m a, Inum t1 t2 m1 b)
pairFinalizer iter inum cleanup = do
mc <- newMVar False
let end = modifyMVar mc $ \cleanit ->
when cleanit cleanup >> return (True, ())
return (iter `finallyI` liftIO end
, (inumNull `cat` inum) `inumFinally` liftIO end)
iterHandle :: (LL.ListLikeIO t e, ChunkData t, MonadIO m) =>
Handle -> IO (Iter t m (), Onum t m a)
iterHandle h = do
hSetBinaryMode h True `onException` hClose h
pairFinalizer (handleI h) (enumNonBinHandle h) (hClose h)
iterStream :: (SendRecvString t, ChunkData t, MonadIO m) =>
Socket -> IO (Iter t m (), Onum t m a)
iterStream s = pairFinalizer (sockStreamI s) (enumStream s) (sClose s)