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 Data.Textual.Class

import Data.Time.ISO8601
import Data.IP
import Data.Default.Class

import Control.Applicative
import Control.Lens

import Text.Read (readMaybe)

import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Attoparsec.ByteString.Char8.Extras
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.List as List

import Debug.Trace

data BackendAction = DATA deriving (Show, Read, Eq, Ord, Bounded, Enum)
data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)

data MaybeMetadata = MaybeMetadata {_mclientId :: Maybe ClientIdentity, _mclientName :: Maybe ByteString,
                                    _mmailFrom :: Maybe Account, _mrcptTo :: [Address], _mrcptFailed :: [(Address, Response)],
                                    _mauth :: Maybe ByteString, _mrecvDate :: Maybe UTCTime, _mbodyEnc :: Mime.BodyEncoding,
                                    _msmtpUtf8 :: Bool, _maction :: Maybe BackendAction, _munrecognized :: [ByteString]
                                   } deriving (Show, Ord, Eq)

data Metadata = Metadata {_clientId :: ClientIdentity, _clientName :: ByteString,
                          _mailFrom :: Account, _rcptTo :: [Address], _rcptFailed :: [(Address, Response)],
                          _auth :: Maybe ByteString, _recvDate :: UTCTime, _bodyEnc :: Mime.BodyEncoding,
                          _smtpUtf8 :: Bool, _action :: BackendAction, _unrecognized :: [ByteString]
                         } deriving (Show, Ord, Eq)

makeLenses ''ClientIdentity
makeLenses ''MaybeMetadata
makeLenses ''Metadata

instance Default MaybeMetadata where
  def = MaybeMetadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing []

metadataForClient :: IP -> Int -> MaybeMetadata
metadataForClient c p = def & mclientId .~ (Just (ClientIdentity c p))
resetMetadata :: MaybeMetadata -> MaybeMetadata
resetMetadata d = def & mclientId .~ d^.mclientId & mclientName .~ d^.mclientName

strictMetadata :: MaybeMetadata -> Maybe Metadata
strictMetadata m = do
  act <- m^.maction
  cid <- m^.mclientId
  cnm <- m^.mclientName
  rfm <- m^.mmailFrom
  let rto = m^.mrcptTo
      rfail = m^.mrcptFailed
      usr = m^.mauth
  rcv <- m^.mrecvDate
  let enc = m^.mbodyEnc
      utf = m^.msmtpUtf8
      unrq = m^.munrecognized
  return $ Metadata cid cnm rfm rto rfail usr rcv enc utf act unrq

renderMetadata :: Metadata -> ByteString
renderMetadata m = BS.concat serialize
  where
    serialize :: [ByteString]
    serialize = let
      act = m^.action
      cid = m^.clientId
      cnm = m^.clientName
      rfm = m^.mailFrom
      rto = m^.rcptTo
      rfail = m^.rcptFailed
      usr = m^.auth
      rcv = m^.recvDate
      enc = m^.bodyEnc
      utf = m^.smtpUtf8
      usrStr = case usr of
        Nothing -> []
        Just u -> ["Auth-User: ", u, "\r\n"]
      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
      unrec = m^.unrecognized
      h = [
        "Action: ", show act, "\r\n",
        "Client-Ip: ", show $ cid^.clientIp, "\r\n",
        "Client-Port: ", show $ cid^.clientPort, "\r\n",
        "Client-Name: ", fromTextual cnm, "\r\n",
        "Return-Path: ", fromTextual . 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]
      in map fromTextual h ++ toStr ++ failStr ++ usrStr ++ unrec

parseMetadata :: A.Parser Metadata
parseMetadata = do
  (m', h', p') <- parserFold parseField (def, Nothing, Nothing)
  A.endOfLine
  let i = do
        h <- h'
        p <- p'
        return $ ClientIdentity h p
      m = set mclientId i m'
  case strictMetadata m of
    Just s -> return s
    Nothing -> failParser
  where
    parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
    parseField = do
      A.choice [
        do
          act <- hdr "Action" parseEnumCI
          trace "Action" $ return ()
          return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
        do
          ip <- hdr "Client-Ip" parseRead
          trace "Client-Ip" $ return ()
          return $ \(m, _, p) -> (m, Just ip, p),
        do
          p <- hdr "Client-Port" parseRead
          trace "Client-Port" $ return ()
          return $ \(m, ip, _) -> (m, ip, Just p),
        do
          nm <- hdr "Client-Name" (A.takeTill A.isSpace)
          trace "Client-Name" $ return ()
          return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
        do
          frm <- hdr "Return-Path" parseAccount
          trace "Return-Path" $ return ()
          return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
        do
          rtp <- hdr "To" parseAddress
          trace "To" $ return ()
          return $ \(m, ip, p) -> let
            crtp = m^.mrcptTo
            in (set mrcptTo (rtp:crtp) m, ip, p),
        do
          rfl <- hdr "Failed" parseAddressingReason
          trace "Failed" $ return ()
          return $ \(m, ip, p) -> let
            fld = m^.mrcptFailed
            in (set mrcptFailed (rfl:fld) m, ip, p),
        do
          recv <- hdr "Recv-Date" parseISO8601Val
          trace "Recv-Date" $ return ()
          return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
        do
          enc <- hdr "Body-Encoding" Mime.parseBodyEncoding
          trace "Body-Encoding" $ return ()
          return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
        do
          utf <- hdr "SMTP-UTF8" parseMetadataBool
          trace "SMTP-UTF8" $ return ()
          return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
        do
          usr <- hdr "Auth-User" bsval
          trace "Auth-User" $ return ()
          return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
        do
          u <- entireHdr
          trace "Unknown" $ return ()
          trace (show u) $ return ()
          return $ \(m, ip, p) -> let
            uu = m^.munrecognized
            in (set munrecognized (u:uu) m, ip, p)
        ]
    entireHdr :: Parser ByteString
    entireHdr = do
      a <- A.satisfy (not . A.isEndOfLine . asW8)
      t <- A.takeTill (A.isEndOfLine . asW8)
      A.endOfLine
      l <- takeLines
      return $ BS.concat [C8.cons a 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
      trace ("testing " ++ show pt) $ return ()
      skipHorizontalSpace
      A.stringCI pt
      trace ("it's it") $ return ()
      skipHorizontalSpace
      A.char ':'
      skipHorizontalSpace
      t <- bsval
      trace ("Will now parse value: " ++ show t) $ return ()
      r <- case A.parseOnly f t of
        Left _ -> failParser
        Right v -> return v
      trace "Got value" $ return ()
      skipHorizontalSpace
      return r
    bsval :: Parser ByteString
    bsval = do
      ll <- entireHdr
      let (b, _) = BS.spanEnd (\x -> x == asW8 '\r' || x == asW8 '\n') ll
      return b
    parseRead :: Read a => Parser a
    parseRead = do
      v <- A.takeTill A.isSpace
      case readMaybe . fromTextual $ v of
        Nothing -> failParser
        Just i -> return i
    parseISO8601Val = do
      v <- A.takeTill A.isSpace
      case parseISO8601 . fromTextual $ 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 <- parseLineResponse
      return (a, r)