fcmtp-data/src/Data/SMTP/Response.hs

{-# LANGUAGE OverloadedStrings #-}
module Data.SMTP.Response (
  ResponseStatus(..),
  Response(..),
  parseResponse,
  parseLineResponse,
  renderResponse,
  renderLineResponse,
  )where

import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Attoparsec.ByteString.Char8.Extras
import Data.Default.Class

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS

import Text.StringConvert

data ResponseStatus = Preliminary | Completion | Intermediate | TransientError | PermanentError
                    deriving (Read, Show, Ord, Eq)
data Response = Response {status :: ResponseStatus, respLines :: [ByteString],
                          code :: Int, extended :: Maybe (Int, Int, Int), message :: ByteString}
              deriving (Read, Show, Ord, Eq)

instance Default Response where
  def = Response PermanentError [] 500 Nothing ""

parseLineResponse :: A.Parser Response
parseLineResponse = do
  (cd, xcd, m, _) <- parseLine
  return $ Response (statusFromCode cd) [] cd xcd m
  

parseResponse :: A.Parser Response
parseResponse = do
  (cd, xcd, m, moreLines) <- parseLine
  A.endOfLine
  lns <- parseLines moreLines
  return $ Response (statusFromCode cd) lns cd xcd m

parseLines :: Bool -> A.Parser [ByteString]
parseLines False = return []
parseLines True = do
  (_, _, m, moreLines) <- parseLine
  A.endOfLine
  lns <- parseLines moreLines
  return $ m : lns

parseLine :: A.Parser (Int, Maybe (Int, Int, Int), ByteString, Bool)
parseLine = A.choice [
  do
    cd  <- A.decimal
    A.string "-"
    xcd <- parsexcode "-"
    m <- A.takeTill (A.isEndOfLine. asW8)
    return (cd, xcd, m, True),
  do
    cd <- A.decimal
    A.string " "
    xcd <- parsexcode " "
    m <- A.takeTill (A.isEndOfLine . asW8)
    return (cd, xcd, m, False)
  ]

parsexcode :: ByteString -> A.Parser (Maybe (Int, Int, Int))
parsexcode sep = A.choice [
  do
    c1 <- A.decimal
    A.string "."
    c2 <- A.decimal
    A.string "."
    c3 <- A.decimal
    A.string sep
    return $ Just (c1, c2, c3),
  return Nothing
  ]

statusFromCode :: Int -> ResponseStatus
statusFromCode c
  | c < 100 = PermanentError
  | c < 200 = Preliminary
  | c < 300 = Completion
  | c < 400 = Intermediate
  | c < 500 = TransientError
  | otherwise = PermanentError

renderResponse :: Response -> ByteString
renderResponse (Response _ lns cd ext msg) = let
  tst = showBS cd
  sep = if null lns then " " else "-"
  enh = case ext of
    Nothing -> ""
    Just (s1, s2, s3) -> BS.intercalate "." $ map showBS [s1, s2, s3]
  in BS.concat $ [tst, sep, enh, if BS.null enh then "" else sep, msg, "\r\n"] ++ renderLines tst enh lns
  where
    renderLines _ _ [] = []
    renderLines tst enh (l:ll) = let
      sep = if null ll then " " else "-"
      in [tst, sep, enh, if BS.null enh then "" else sep, l, "\r\n"] ++ renderLines tst enh ll

renderLineResponse :: Response -> ByteString
renderLineResponse (Response _ _ cd ext msg) = let
  tst = showBS cd
  sep = " "
  enh = case ext of
    Nothing -> ""
    Just (s1, s2, s3) -> BS.intercalate "." $ map showBS [s1, s2, s3]
  in BS.concat [tst, sep, enh, if BS.null enh then "" else sep, msg]

showBS :: Show a => a -> ByteString
showBS = s . show