ChunkyLazyIO.hs

module Network.Monad.Transfer.ChunkyLazyIO (
   Body(length),
   transfer,
   run,
   ) where

import qualified Network.Monad.Transfer as Transfer
import qualified Network.Monad.Reader as Reader
import qualified Network.Monad.Body as Body

import qualified Network.TCP as TCP
import Control.Monad.Trans.Reader (ReaderT, runReaderT, )

import qualified Control.Monad.Exception.Asynchronous as Async

import qualified System.IO.Lazy as LazyIO
import Data.Monoid (Monoid, mempty, mappend, )

import qualified Data.List as List

import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as BL

import Prelude hiding (length, )



class Body.C body => Body body where
   length :: body -> Int

instance Body.CharType char => Body [char] where
   length = List.length

instance Body BS.ByteString where
   length = BS.length

{-
@fromIntegral@ converts from Int64 to Int which is dangerous in general
but in our case,
since we only use it to check the length of actually read data
that is never more than 2^31 because that's the maximum possible chunk size.
-}
instance Body BL.ByteString where
   length = fromIntegral . BL.length



transfer :: (TCP.HStream body, Body body) =>
   Int {-^ chunk size, only relevant for 'Transfer.readBlock'. -} ->
   TCP.HandleStream body ->
   Transfer.T LazyIO.T body
transfer chunkSize h =
   Transfer.Cons {
      Transfer.readLine   =         Transfer.liftIOAsync $ TCP.readLine h,
      Transfer.readBlock  = \n   -> readBlockChunky chunkSize h n,
      Transfer.writeBlock = \str -> Transfer.liftIOSync  $ TCP.writeBlock h str
   }

run :: (TCP.HStream body, Body body) =>
   Reader.T body LazyIO.T a
       {-^ dictionary for read and write methods -} ->
   Int {-^ chunk size -} ->
   TCP.HandleStream body ->
   IO a
run m chunkSize h = LazyIO.run $ runReaderT m $ transfer chunkSize h


readBlockChunky :: (TCP.HStream body, Body body) =>
   Int -> TCP.HandleStream body -> Int -> Transfer.AsyncExceptional LazyIO.T body
readBlockChunky chunkSize h =
   let go todo =
         if todo>0
           then -- we cannot use 'mappend' because 'length str' is needed
                do (Transfer.liftIOAsync $
                    TCP.readBlock h (min chunkSize todo))
                   `Async.bindT`
                   (\str ->
                       fmap (mappend str) $ go (max 0 (todo - length str)))
           else mempty
   in  go