fcmtp-data/src/Data/SMTP/Types/Resource.hs

module Data.SMTP.Types.Resource where

import qualified Data.SMTP.URI as URI
import qualified Data.SMTP.Types.Mime as Mime
import qualified Data.SMTP.Parser.Mime as PMime
import qualified Data.Attoparsec.ByteString as BA

import qualified Data.ByteString.Lazy as LBS
import qualified Text.StringConvert as SC

import Data.Maybe
import Data.Default.Class

import Data.Char

data Header = Header (String, String) deriving (Read, Show, Eq, Ord)

data ResourceInfo = ResourceInfo {
  mimeType :: Mime.ContentType,
  mimeParameters :: Mime.ContentTypeParameters,
  revision :: URI.Revision,
  bases :: [URI.Revision],
  address :: [URI.URI]
  } deriving (Eq, Ord, Show)
instance Default ResourceInfo where
  def = ResourceInfo def def URI.NoRevision [] []

type ResourceData = LBS.ByteString

getHeader :: [Header] -> String -> Maybe Header
getHeader [] _ = Nothing
getHeader (h@(Header (hk, _)) : hh) k
  | map toLower hk == map toLower k = Just h
  | otherwise = getHeader hh k

getHeaderValue :: [Header] -> String -> Maybe String
getHeaderValue hh h = case getHeader hh h of
  Just (Header (_, v)) -> Just v
  Nothing -> Nothing

getMultiple :: [Header] -> String -> [Header]
getMultiple hh h = filter (\(Header (k, _)) -> k == h) hh

getMultipleValue :: [Header] -> String -> [String]
getMultipleValue hh = map (\(Header (_, v)) -> v) . getMultiple hh

revisionHeader :: String
revisionHeader = "fCMTP-Revision"

baseHeader :: String
baseHeader = "fCMTP-Revision-Base"

addressHeader :: String
addressHeader = "fCMTP-Address"

resourceInfo :: [Header] -> ResourceInfo
resourceInfo hh = let
  (mimet, mimep) = fromMaybe (def, def) $ getHeaderValue hh Mime.contentTypeHeaderName >>= bparse PMime.parseContentType
  curr = fromMaybe URI.NoRevision $ URI.Revision <$> getHeaderValue hh revisionHeader
  bb = map URI.Revision $ getMultipleValue hh baseHeader
  uu = catMaybes . map (bparse URI.parseURI) $ getMultipleValue hh addressHeader
  in ResourceInfo mimet mimep curr bb uu
  where
    bparse :: BA.Parser a -> String -> Maybe a
    bparse p v = eitherToMaybe . BA.parseOnly p $ SC.s v 
    eitherToMaybe (Left _) = Nothing
    eitherToMaybe (Right v) = Just v