walrus-backend/src/Walrus/Backend/Metadata.hs

{-# 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)