Removed Encoding frm hssealtools

src/Walrus/Backend.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Walrus.Backend (
+  Backend(..),
+  module Walrus.Backend.Metadata,
   parseBackend,
   runBackend
   ) where
@@ -10,10 +12,9 @@ import qualified Data.Attoparsec.ByteString.Lazy as LA
 import Data.Attoparsec.ByteString.Char8.Extras
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Char as C
-import Encoding
+import Data.Text.IsText
 
 import Walrus.Backend.Metadata
-import Walrus.Backend.Request
 
 import Control.Applicative
 
@@ -21,7 +22,8 @@ import Network
 import System.IO
 import qualified System.Process as P
 
-data Backend = TCPBackend String Int | UnixSocketBackend String | ExecBackend String [String]
+data Backend = TCPBackend String Int | UnixSocketBackend String |
+               ExecBackend String [String] deriving (Show, Read, Ord, Eq)
 
 parseBackend :: A.Parser Backend
 parseBackend = do
@@ -48,21 +50,20 @@ parseBackend = do
       A.stringCI t
       skipHorizontalSpace
     tillSpace :: A.Parser String
-    tillSpace = bsutf8 <$> A.takeTill C.isSpace
+    tillSpace = fromText <$> A.takeTill C.isSpace
     qStr :: A.Parser String
-    qStr = bsutf8 <$> quotedString '\\' " " ""
+    qStr = fromText <$> quotedString '\\' " " ""
     parseParameters = A.many' $ do
       p <- qStr
       skipHorizontalSpace
       return p
 
-runBackend :: Backend -> (Request, Metadata, LBS.ByteString) -> IO (Either String (Metadata, LBS.ByteString))
-runBackend b (req, m, qdt) = case renderMetadata m of
+runBackend :: Backend -> (Metadata, LBS.ByteString) -> IO (Either String (Metadata, LBS.ByteString))
+runBackend b (m, qdt) = case renderMetadata m of
   Nothing -> return $ Left "Metadata error"
   Just rm -> do
     edt' <- intBk b $ LBS.concat [
-      LBS.fromStrict . utf8bs . show $ req,
-      LBS.fromStrict rm,
+      fromText rm,
       "\r\n",
       qdt]
     case LA.parse repParse edt' of

src/Walrus/Backend/Metadata.hs

@@ -10,7 +10,7 @@ import SMTP.Address
 import SMTP.Account
 import qualified SMTP.Mime as Mime
 import SMTP.Response
-import Encoding
+import Data.Text.IsText
 
 import Data.Time.ISO8601
 import Data.IP
@@ -28,19 +28,20 @@ import Data.Attoparsec.ByteString.Char8.Extras
 import qualified Data.ByteString as BS
 import qualified Data.List as List
 
+data BackendAction = DATA deriving (Show, Read, Eq, Ord, Bounded, Enum)
 data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)
 
 data Metadata = Metadata {_clientId :: Maybe ClientIdentity, _clientName :: Maybe ByteString,
                           _mailFrom :: Maybe Account, _rcptTo :: [Address], _rcptFailed :: [(Address, Response)],
                           _auth :: Maybe ByteString, _recvDate :: Maybe UTCTime, _bodyEnc :: Mime.BodyEncoding,
-                          _smtpUtf8 :: Bool, _unrecognized :: [ByteString]
+                          _smtpUtf8 :: Bool, _action :: Maybe BackendAction, _unrecognized :: [ByteString]
                          } deriving (Show, Ord, Eq)
 
 makeLenses ''ClientIdentity
 makeLenses ''Metadata
 
 instance Default Metadata where
-  def = Metadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False []
+  def = Metadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing []
 
 metadataForClient :: IP -> Int -> Metadata
 metadataForClient c p = def & clientId .~ (Just (ClientIdentity c p))
@@ -48,10 +49,11 @@ resetMetadata :: Metadata -> Metadata
 resetMetadata d = def & clientId .~ d^.clientId & clientName .~ d^.clientName
 
 renderMetadata :: Metadata -> Maybe ByteString
-renderMetadata m = BS.concat <$> serialize
+renderMetadata m = BS.concat . map fromText <$> serialize
   where
     serialize :: Maybe [ByteString]
     serialize = do
+      act <- m^.action
       cid <- m^.clientId
       cnm <- m^.clientName
       rfm <- m^.mailFrom
@@ -64,18 +66,20 @@ renderMetadata m = BS.concat <$> serialize
           usrStr = case usr of
             Nothing -> []
             Just u -> ["Auth-User: ", u, "\r\n"]
-      let toStr = List.concat $ map (\x -> ["To: ", renderMetadataAddress x, "\r\n"]) rto
+      let toStr = List.concat $ map (\x -> ["To: ", renderMetadataAddress $ x, "\r\n"]) rto
           failStr = List.concat $ map (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderResponse r, "\r\n"]) rfail
       let unrec = m^.unrecognized
-      return $ [
-        "Client-Ip: ", utf8bs . show $ cid^.clientIp, "\r\n",
-        "Client-Port: ", utf8bs . show $ cid^.clientPort, "\r\n",
-        "Client-Name: ", cnm, "\r\n",
-        "Return-Path: ", normalAccountName $ rfm, "\r\n",
-        "Recv-Date: ", utf8bs . formatISO8601 $ rcv, "\r\n",
-        "Body-Encoding: ", utf8bs . show $ enc, "\r\n",
-        "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
-        ] ++ toStr ++ failStr ++ usrStr ++ unrec
+      let h = [
+            "Action: ", show act, "\r\n",
+            "Client-Ip: ", show $ cid^.clientIp, "\r\n",
+            "Client-Port: ", show $ cid^.clientPort, "\r\n",
+            "Client-Name: ", fromText cnm, "\r\n",
+            "Return-Path: ", fromText . normalAccountName $ rfm, "\r\n",
+            "Recv-Date: ", formatISO8601 $ rcv, "\r\n",
+            "Body-Encoding: ", show $ enc, "\r\n",
+            "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
+            ] :: [String]
+      return $ map fromText h ++ toStr ++ failStr ++ usrStr ++ unrec
 
 isMetadataComplete :: Metadata -> Bool
 isMetadataComplete = isJust . renderMetadata
@@ -96,6 +100,9 @@ parseMetadata = do
     parseField = do
       skipHorizontalSpace
       A.choice [
+        do
+          act <- hdr "Action" parseEnumCI
+          return $ \(m, ip, p) -> (set action (Just act) m, ip, p),
         do
           ip <- hdr "Client-Ip" parseRead
           return $ \(m, _, p) -> (m, ip, p),
@@ -180,7 +187,7 @@ parseMetadata = do
     parseRead :: Read a => Parser a
     parseRead = do
       v <- bsval
-      case readMaybe . bsutf8 $ v of
+      case readMaybe . fromText $ v of
         Nothing -> failParser
         Just i -> return i
     parseVal :: Parser a -> Parser a
@@ -195,7 +202,7 @@ parseMetadata = do
     parseBoolVal = parseVal parseMetadataBool
     parseISO8601Val = do
       v <- bsval
-      case parseISO8601 . bsutf8 $ v of
+      case parseISO8601 . fromText $ v of
         Nothing -> failParser
         Just t -> return t
     parseMetadataBool :: Parser Bool

src/Walrus/Backend/Request.hs

@@ -1,9 +0,0 @@
-module Walrus.Backend.Request where
-
-import Data.Attoparsec.ByteString
-import Data.Attoparsec.ByteString.Char8.Extras
-
-data Request = DATA deriving (Show, Read, Eq, Ord, Bounded, Enum)
-
-parseRequest :: Parser Request
-parseRequest = parseEnumCI

walrus-backend.cabal

@@ -19,7 +19,6 @@ library
   exposed-modules:
     Walrus.Backend
     Walrus.Backend.Metadata
-    Walrus.Backend.Request
   -- other-modules:       
   other-extensions:    OverloadedStrings, TemplateHaskell
   build-depends:
@@ -37,6 +36,8 @@ library
     lens,
     iso8601-time,
     tools-for-attoparsec,
+    istext,
     hssealtools
   hs-source-dirs:      src
+  ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded
   default-language:    Haskell2010