Browse Source

Initial version

Marcos Dumay de Medeiros 8 years ago
commit
38f87900ee
5 changed files with 256 additions and 0 deletions
  1. 4 0
      .gitignore
  2. 0 0
      LICENSE
  3. 2 0
      Setup.hs
  4. 214 0
      src/Walrus/Backend/Metadata.hs
  5. 36 0
      walrus-backend.cabal

+ 4 - 0
.gitignore

@@ -0,0 +1,4 @@
+dist/
+.cabal-sandbox/
+cabal.sandbox.config
+*~

+ 0 - 0
LICENSE


+ 2 - 0
Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

+ 214 - 0
src/Walrus/Backend/Metadata.hs

@@ -0,0 +1,214 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Walrus.Backend.Metadata where
+
+import Data.ByteString (ByteString)
+import Data.Time.Clock (UTCTime)
+
+import SMTP.Address
+import SMTP.Account
+import qualified SMTP.Mime as Mime
+import SMTP.Response
+import Encoding
+
+import Data.Time.ISO8601
+import Data.IP
+import Data.Default.Class
+
+import Control.Applicative
+import Control.Lens
+
+import Text.Read (readMaybe)
+import Data.Maybe (isJust)
+
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import SMTP.Parser.ParserTools
+import qualified Data.ByteString as BS
+import qualified Data.List as List
+
+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]
+                         } deriving (Read, Show, Ord, Eq)
+
+makeLenses ''ClientIdentity
+makeLenses ''Metadata
+
+instance Default Metadata where
+  def = Metadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False []
+
+metadataForClient :: IP -> Int -> Metadata
+metadataForClient c p = def & clientId .~ (Just (ClientIdentity c p))
+resetMetadata :: Metadata -> Metadata
+resetMetadata d = def & clientId .~ d^.clientId & clientName .~ d^.clientName
+
+renderMetadata :: Metadata -> Maybe ByteString
+renderMetadata m = BS.concat <$> serialize
+  where
+    serialize :: Maybe [ByteString]
+    serialize = do
+      cid <- m^.clientId
+      cnm <- m^.clientName
+      rfm <- m^.mailFrom
+      let rto = m^.rcptTo
+          rfail = m^.rcptFailed
+          usr = m^.auth
+      rcv <- m^.recvDate
+      let enc = m^.bodyEnc
+          utf = m^.smtpUtf8
+          usrStr = case usr of
+            Nothing -> []
+            Just u -> ["Auth-User: ", u, "\r\n"]
+      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
+
+isMetadataComplete :: Metadata -> Bool
+isMetadataComplete = isJust . renderMetadata
+
+parseMetadata :: A.Parser Metadata
+parseMetadata = do
+  (m', h', p') <- parseFold parseField (def, Nothing, Nothing)
+  let i = do
+        h <- h'
+        p <- p'
+        return $ ClientIdentity h p
+      m = set clientId i m'
+  if isMetadataComplete m
+    then return m
+    else failParser
+  where
+    parseField :: Parser ((Metadata, Maybe IP, Maybe Int) -> (Metadata, Maybe IP, Maybe Int))
+    parseField = do
+      skipHorizontalSpace
+      A.choice [
+        do
+          ip <- hdr "Client-Ip" parseRead
+          return $ \(m, _, p) -> (m, ip, p),
+        do
+          p <- hdr "Client-Port" parseRead
+          return $ \(m, ip, _) -> (m, ip, p),
+        do
+          nm <- hdr "Client-Name" bsval
+          return $ \(m, ip, p) -> (set clientName (Just nm) m, ip, p),
+        do
+          frm <- hdr "Return-Path" parseAccountVal
+          return $ \(m, ip, p) -> (set mailFrom (Just frm) m, ip, p),
+        do
+          rtp <- hdr "To" parseAddressingVal
+          return $ \(m, ip, p) -> let
+            crtp = m^.rcptTo
+            in (set rcptTo (rtp:crtp) m, ip, p),
+        do
+          rfl <- hdr "Failed" (parseAddressingReason)
+          return $ \(m, ip, p) -> let
+            fld = m^.rcptFailed
+            in (set rcptFailed (rfl:fld) m, ip, p),
+        do
+          recv <- hdr "Recv-Date" parseISO8601Val
+          return $ \(m, ip, p) -> (set recvDate (Just recv) m, ip, p),
+        do
+          enc <- hdr "Body-Encoding" parseEncodingVal
+          return $ \(m, ip, p) -> (set bodyEnc enc m, ip, p),
+        do
+          utf <- hdr "SMTP-UTF8" parseBoolVal
+          return $ \(m, ip, p) -> (set smtpUtf8 utf m, ip, p),
+        do
+          usr <- hdr "Auth-User" bsval
+          return $ \(m, ip, p) -> (set auth (Just usr) m, ip, p),
+        do
+          u <- entireHdr
+          return $ \(m, ip, p) -> let
+            uu = m^.unrecognized
+            in (set unrecognized (u:uu) m, ip, p)
+        ]
+    entireHdr :: Parser ByteString
+    entireHdr = do
+      t <- A.takeTill (A.isEndOfLine . asW8)
+      A.endOfLine
+      l <- takeLines
+      return $ BS.concat [t, "\r\n", l]
+    takeLines :: Parser ByteString
+    takeLines = do
+      c' <- A.peekChar
+      case c' of
+        Nothing -> return ""
+        Just c -> if isCHorizontalSpace c
+                  then do
+                    l <- A.takeTill (A.isEndOfLine . asW8)
+                    A.endOfLine
+                    ll <- takeLines
+                    return $ BS.concat [l, "\r\n", ll]
+                   else return ""
+    hdr :: ByteString -> Parser a -> Parser a
+    hdr pt f = do
+      skipHorizontalSpace
+      A.stringCI pt
+      skipHorizontalSpace
+      A.char ':'
+      skipHorizontalSpace
+      r <- f
+      skipHorizontalSpace
+      A.endOfLine
+      return r
+    bsval :: Parser ByteString
+    bsval = do
+      v <- A.takeTill (A.isEndOfLine . asW8)
+      A.endOfLine
+      c' <- A.peekChar
+      case c' of
+        Nothing -> return v
+        Just c -> if isCHorizontalSpace c
+                  then do
+                    v' <- bsval
+                    return $ BS.concat [v, " ", v']
+                  else return v
+    parseRead :: Read a => Parser a
+    parseRead = do
+      v <- bsval
+      case readMaybe . bsutf8 $ v of
+        Nothing -> failParser
+        Just i -> return i
+    parseVal :: Parser a -> Parser a
+    parseVal p = do
+      v <- bsval
+      case A.parseOnly p v of
+        Left _ -> failParser
+        Right v' -> return v'
+    parseAccountVal = parseVal parseAccount
+    parseAddressingVal = parseVal parseMetadataAddress
+    parseEncodingVal = parseVal Mime.parseBodyEncoding
+    parseBoolVal = parseVal parseMetadataBool
+    parseISO8601Val = do
+      v <- bsval
+      case parseISO8601 . bsutf8 $ v of
+        Nothing -> failParser
+        Just t -> return t
+    parseMetadataBool :: Parser Bool
+    parseMetadataBool = do
+      A.choice [
+        A.stringCI "YES" *> return True,
+        A.stringCI "NO" *> return False
+        ]
+    parseAddressingReason :: Parser (Address, Response)
+    parseAddressingReason = do
+      a <- parseMetadataAddress
+      skipHorizontalSpace
+      A.char ';'
+      skipHorizontalSpace
+      r <- parseResponse
+      return (a, r)

+ 36 - 0
walrus-backend.cabal

@@ -0,0 +1,36 @@
+-- Initial walrus-backend.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                walrus-backend
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+-- license:             
+license-file:        LICENSE
+author:              Marcos Dumay de Medeiros
+maintainer:          marcos@marcosdumay.com
+-- copyright:           
+category:            System
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Walrus.Backend.Metadata
+  -- other-modules:       
+  other-extensions:    OverloadedStrings, TemplateHaskell
+  build-depends:
+    base >=4.7 && <4.8,
+    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,
+    lens,
+    iso8601-time,
+    hssealtools
+  hs-source-dirs:      src
+  default-language:    Haskell2010