|
@@ -7,9 +7,10 @@
|
|
|
module System.IO.Uniform.Targets (
|
|
|
TlsSettings(..),
|
|
|
UniformIO(..),
|
|
|
- SocketIO, FileIO, StdIO, TlsIO, SomeIO(..),
|
|
|
+ SocketIO, FileIO, StdIO, TlsIO, SomeIO(..), ByteStringIO,
|
|
|
BoundedPort, connectTo, connectToHost, bindPort, accept, closePort,
|
|
|
openFile, getPeer,
|
|
|
+ withByteStringIO, withByteStringIO',
|
|
|
mapOverInput)
|
|
|
where
|
|
|
|
|
@@ -20,11 +21,15 @@ import Foreign.C.Error
|
|
|
import qualified Data.IP as IP
|
|
|
import Data.ByteString (ByteString)
|
|
|
import qualified Data.ByteString as BS
|
|
|
+import qualified Data.ByteString.Lazy as LBS
|
|
|
+import qualified Data.ByteString.Builder as BSBuild
|
|
|
import qualified Data.List as L
|
|
|
import Control.Exception
|
|
|
import Control.Applicative ((<$>))
|
|
|
+import Data.Monoid (mappend)
|
|
|
import qualified Network.Socket as Soc
|
|
|
import System.IO.Error
|
|
|
+import Control.Concurrent.MVar
|
|
|
|
|
|
import Data.Default.Class
|
|
|
|
|
@@ -192,6 +197,28 @@ instance UniformIO TlsIO where
|
|
|
startTls _ s = return s
|
|
|
isSecure _ = True
|
|
|
|
|
|
+
|
|
|
+data ByteStringIO = ByteStringIO {bsioinput :: MVar (ByteString, Bool), bsiooutput :: MVar BSBuild.Builder}
|
|
|
+instance UniformIO ByteStringIO where
|
|
|
+ uRead s n = do
|
|
|
+ (i, eof) <- takeMVar . bsioinput $ s
|
|
|
+ if eof
|
|
|
+ then do
|
|
|
+ putMVar (bsioinput s) (i, eof)
|
|
|
+ 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)
|
|
|
+ putMVar (bsioinput s) (i', eof')
|
|
|
+ return r
|
|
|
+ uPut s t = do
|
|
|
+ o <- takeMVar . bsiooutput $ s
|
|
|
+ let o' = mappend o $ BSBuild.byteString t
|
|
|
+ putMVar (bsiooutput s) o'
|
|
|
+ uClose _ = return ()
|
|
|
+ startTls _ _ = return . TlsIO $ nullPtr
|
|
|
+ isSecure _ = True
|
|
|
+
|
|
|
|
|
|
|
|
|
|
|
@@ -299,17 +326,37 @@ closeFd (Fd f) = c_closeFd f
|
|
|
closePort :: BoundedPort -> IO ()
|
|
|
closePort p = c_closePort (lis p)
|
|
|
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+withByteStringIO :: ByteString -> (ByteStringIO -> IO a) -> IO (a, LBS.ByteString)
|
|
|
+withByteStringIO input f = do
|
|
|
+ ivar <- newMVar (input, False)
|
|
|
+ ovar <- newMVar . BSBuild.byteString $ BS.empty
|
|
|
+ let bsio = ByteStringIO ivar ovar
|
|
|
+ a <- f bsio
|
|
|
+ out <- takeMVar . bsiooutput $ bsio
|
|
|
+ return (a, BSBuild.toLazyByteString out)
|
|
|
+
|
|
|
+
|
|
|
+withByteStringIO' :: ByteString -> (ByteStringIO -> IO a) -> IO (a, ByteString)
|
|
|
+withByteStringIO' input f = do
|
|
|
+ (a, t) <- withByteStringIO input f
|
|
|
+ return (a, LBS.toStrict t)
|
|
|
+
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-mapOverInput :: UniformIO io => io -> Int -> (a -> ByteString -> IO a) -> a -> IO a
|
|
|
+mapOverInput :: forall a io. UniformIO io => io -> Int -> (a -> ByteString -> IO a) -> a -> IO a
|
|
|
mapOverInput io block f initial = do
|
|
|
a <- tryIOError $ uRead io block
|
|
|
case a of
|
|
|
Left e -> if isEOFError e then return initial else throw e
|
|
|
- Right dt -> mapOverInput io block f (f initial dt)
|
|
|
+ Right dt -> do
|
|
|
+ i <- f initial dt
|
|
|
+ mapOverInput io block f i
|
|
|
|
|
|
|
|
|
foreign import ccall interruptible "getPort" c_getPort :: CInt -> IO (Ptr Nethandler)
|