Browse Source

Added ConduitHandler

Marcos Dumay de Medeiros 8 years ago
parent
commit
d643adfca5
3 changed files with 65 additions and 40 deletions
  1. 27 5
      src/Walrus/Backend.hs
  2. 18 18
      src/Walrus/Backend/Metadata.hs
  3. 20 17
      walrus-backend.cabal

+ 27 - 5
src/Walrus/Backend.hs

@@ -4,20 +4,23 @@ module Walrus.Backend (
   Backend(..),
   LazyHandler,
   UIOHandler,
+  ConduitHandler,
   module Walrus.Backend.Metadata,
   parseBackend,
   callBackend,
   runLazyOnce,
-  runUIOOnce
+  runUIOOnce,
+  runConduitOnce
   ) where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.Attoparsec.ByteString.Lazy as LA
 import Data.Attoparsec.ByteString.Char8.Extras
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Char as C
 import Control.Monad.IO.Class
-import Text.StringConvert
+import qualified Text.StringConvert as SC
 import Control.Lens
 
 import Walrus.Backend.Metadata
@@ -29,12 +32,17 @@ import qualified System.IO.Uniform.Streamline as S
 --import System.IO.Uniform.HandlePair as HP
 --import System.IO.Uniform.Network as Net
 import qualified System.Process as P
+import qualified System.IO.Uniform.Conduit as CIO
+import Data.Conduit
+import qualified Data.Conduit.Attoparsec as CA
+import qualified Data.Conduit.List as CL
 
 data Backend = TCPBackend String Int |
                ExecBackend String [String] deriving (Show, Read, Ord, Eq)
 
 type LazyHandler = Metadata -> LBS.ByteString -> IO (Either String (Metadata, LBS.ByteString))
 type UIOHandler = Metadata -> S.Streamline IO (Either String (Metadata, LBS.ByteString))
+type ConduitHandler = Metadata -> ConduitM BS.ByteString BS.ByteString IO (Either String (Metadata, LBS.ByteString))
 
 parseBackend :: A.Parser Backend
 parseBackend = A.choice [
@@ -56,7 +64,7 @@ parseBackend = A.choice [
       A.stringCI t
       skipHorizontalSpace
     tillSpace :: A.Parser String
-    tillSpace = s <$> A.takeTill C.isSpace
+    tillSpace = SC.s <$> A.takeTill C.isSpace
     parseParameters :: A.Parser [String]
     parseParameters = do
       p <- qStr
@@ -65,13 +73,13 @@ parseBackend = A.choice [
         pp <- parseParameters
         return $ p : pp
     qStr :: A.Parser String
-    qStr = s <$> quotedString '\\' " " ""
+    qStr = SC.s <$> quotedString '\\' " " ""
 
 callBackend :: Backend -> (Metadata, LBS.ByteString) -> IO (Either String (Metadata, LBS.ByteString))
 callBackend b (m, qdt) = do
   let rm = renderMetadata m
   edt' <- intBk b $ LBS.concat [
-    s rm,
+    SC.s rm,
     qdt]
   case LA.parse repParse edt' of
     LA.Fail _ _ e -> return $ Left e
@@ -111,6 +119,20 @@ runUIOOnce u f =  S.withTarget u $ do
           S.send' dto
           return . Right $ ()
 
+runConduitOnce :: UniformIO u => u -> ConduitHandler -> IO (Either String ())
+runConduitOnce u f = CIO.runConduit u $ do
+  m' <- CA.sinkParserEither parseMetadata
+  case m' of
+    Left e -> return . Left . show $ e
+    Right m -> do
+      r <- f m
+      case r of
+        Left e -> return . Left $ e
+        Right (mo, dto) -> do
+          yield . renderMetadata $ mo
+          CL.sourceList . LBS.toChunks $ dto
+          return . Right $ ()
+
 runTcp :: String -> Int -> LBS.ByteString -> IO LBS.ByteString
 runTcp host port dt = do
   h <- connectTo host (PortNumber . fromIntegral $ port)

+ 18 - 18
src/Walrus/Backend/Metadata.hs

@@ -12,7 +12,7 @@ import Data.SMTP.Account
 --import qualified Data.SMTP.URI as URI
 import qualified Data.SMTP.Mime as Mime
 import Data.SMTP.Response
-import Text.StringConvert
+import qualified Text.StringConvert as SC
 
 import Data.Time.ISO8601
 import Data.IP
@@ -59,7 +59,7 @@ data MaybeMetadata = MaybeMetadata {_mclientId :: Maybe ClientIdentity, _mclient
 uq :: Eq a => (b -> a) -> b -> b -> Bool
 uq f a b = f a == f b
 
-sq :: (Eq a, Ord a) => (b -> [a]) -> b -> b -> Bool
+sq :: Ord a => (b -> [a]) -> b -> b -> Bool
 sq f a b = (List.sort . f $ a) == (List.sort . f $ b)
 
 -- | All the data of a backend metadata, as the walrus specification.
@@ -233,7 +233,7 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
         "Recv-Date: ", formatISO8601 rcv, "\r\n",
         "Data-Size: ", show sz, "\r\n"
         ] :: [String]
-      in map s h ++ usrStr ++ unrec
+      in map SC.s h ++ usrStr ++ unrec
     serializeDt = case m^.actionData of
       Deliver dt -> "Action: DELIVER\r\n" : serializeDeliver dt
       WillHandle dt -> "Action: WILLHANDLE\r\n" : serializeHandle dt
@@ -250,32 +250,32 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
       toStr = List.concatMap (\x -> ["To: ", fullAccount x, "\r\n"]) rto
       failStr = List.concatMap (\(a, r) -> ["Failed: ", fullAccount a, "; ", renderLineResponse r, "\r\n"]) rfail
       h = [
-        "Client-Name: ", s cnm, "\r\n",
-        "Return-Path: ", s . normalize $ rfm, "\r\n",
+        "Client-Name: ", SC.s cnm, "\r\n",
+        "Return-Path: ", SC.s . normalize $ rfm, "\r\n",
         "Body-Encoding: ", show enc, "\r\n",
         "SMTP-UTF8: ", serialBool utf, "\r\n"
         ] :: [String]
-      in map s h ++ toStr ++ failStr
-    serializeHandle (AccountRequest a) = ["To: ", s . fullAccount $ a, "\r\n"]
+      in map SC.s h ++ toStr ++ failStr
+    serializeHandle (AccountRequest a) = ["To: ", SC.s . fullAccount $ a, "\r\n"]
     serializeHandle (AccountResponse (a, r)) = ["Failed: ", fullAccount a, "; ", renderLineResponse r, "\r\n"]
     serializeHandle AccountOk = []
     serializeFetchResc (FetchRescData cnm rfm ofst sz trg resp) =
-      ["Client-Name: ", s cnm, "\r\n",
-       "Return-Path: ", s . normalize $ rfm, "\r\n",
+      ["Client-Name: ", SC.s cnm, "\r\n",
+       "Return-Path: ", SC.s . normalize $ rfm, "\r\n",
        "Headers: No\r\n",
-       "Offset: ", s . show $ ofst, "\r\n",
-       "Block-Size: ", s . show $ sz, "\r\n",
-       "Target: ", s . show $ trg, "\r\n"] ++
+       "Offset: ", SC.s . show $ ofst, "\r\n",
+       "Block-Size: ", SC.s . show $ sz, "\r\n",
+       "Target: ", SC.s . show $ trg, "\r\n"] ++
       case resp of
         Nothing -> []
         Just r -> ["Failure: ", renderLineResponse r, "\r\n"]
     serializeFetchHdr (FetchHdrData cnm rfm r q trg resp) =
-      ["Client-Name: ", s cnm, "\r\n",
-       "Return-Path: ", s . normalize $ rfm, "\r\n",
+      ["Client-Name: ", SC.s cnm, "\r\n",
+       "Return-Path: ", SC.s . normalize $ rfm, "\r\n",
        "Headers: Yes\r\n",
        "Recursive: ", serialBool r, "\r\n",
        "Query: ", serializeFtchQuery q, "\r\n",
-       "Target: ", s . show $ trg, "\r\n"] ++
+       "Target: ", SC.s . show $ trg, "\r\n"] ++
       case resp of
         Nothing -> []
         Just rs -> ["Failure: ", renderLineResponse rs, "\r\n"]
@@ -398,7 +398,7 @@ parseMetadata = do
       skipHorizontalSpace
       t <- bsval
       r <- case A.parseOnly f t of
-        Left _ -> fail $ "failed parsing value of " ++ s pt
+        Left _ -> fail $ "failed parsing value of " ++ SC.s pt
         Right v -> return v
       skipHorizontalSpace
       return r
@@ -410,12 +410,12 @@ parseMetadata = do
     parseRead :: Read a => Parser a
     parseRead = do
       v <- A.takeTill A.isSpace
-      case readMaybe . s $ v of
+      case readMaybe . SC.s $ v of
         Nothing -> fail "failed parsing value"
         Just i -> return i
     parseISO8601Val = do
       v <- A.takeTill A.isSpace
-      case parseISO8601 . s $ v of
+      case parseISO8601 . SC.s $ v of
         Nothing -> fail "failed parsing ISO8601 date"
         Just t -> return t
     parseMetadataBool :: Parser Bool

+ 20 - 17
walrus-backend.cabal

@@ -22,23 +22,26 @@ library
   -- other-modules:       
   other-extensions:    OverloadedStrings, TemplateHaskell
   build-depends:
-    base >=4.7,
-    time >=1.5,
-    transformers >= 0.3.0,
-    unix >=2.7.1,
-    bytestring >=0.10,
-    time >=1.5,
-    iproute >=1.7,
-    data-default-class,
-    attoparsec >=0.11,
-    network >= 2.6,
-    process >= 1.2,
-    lens,
-    iso8601-time,
-    string-convert,
-    tools-for-attoparsec,
-    fcmtp-data,
-    uniform-io >= 1.1.1
+                base >=4.7,
+                time >=1.5,
+                transformers >= 0.3.0,
+                unix >=2.7.1,
+                bytestring >=0.10,
+                time >=1.5,
+                iproute >=1.7,
+                data-default-class,
+                attoparsec >=0.11,
+                network >= 2.6,
+                process >= 1.2,
+                lens,
+                iso8601-time,
+                string-convert,
+                tools-for-attoparsec,
+                fcmtp-data,
+                conduit,
+                conduit-extra,
+                uniform-io >= 1.1.1
   hs-source-dirs:      src
+
   ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded
   default-language:    Haskell2010