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

{-# LANGUAGE OverloadedStrings #-}

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 as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Text.StringConvert as SC

import Data.Maybe
import Data.Default.Class

import qualified Data.Char as C

data Header = Header {key :: String, value :: String, bare :: BS.ByteString} deriving (Read, Show, Eq, Ord)
data PlainHeaders = PlainHeaders {public :: [Header], sealed :: [Header], separators :: (BS.ByteString, BS.ByteString)} deriving (Read, Show, Eq, Ord)
instance Default PlainHeaders where
  def = PlainHeaders [] [] ("\r\n", "")

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

-- | Creates a header from a key and a value
makeHeader :: String -> String -> Header
makeHeader k v = Header k v . SC.s $ k ++ ": " ++ v ++ "\r\n"

-- | True if the header key matches
hasKey :: String -> Header -> Bool
hasKey k h = map C.toLower k == key h

-- | Retrieves a single header with the given key
getHeader :: [Header] -> String -> Maybe Header
getHeader hh k = case getMultiple hh k of
  [] -> Nothing
  (h:_) -> Just h

-- | Retrieves the value of the header that matches key
getHeaderValue :: [Header] -> String -> Maybe String
getHeaderValue hh k = value <$> getHeader hh k

-- | Retrieves all headers that match the key
getMultiple :: [Header] -> String -> [Header]
getMultiple hh k = filter (hasKey k) hh

-- | Retrieves all the values of the headers that match the key
getMultipleValue :: [Header] -> String -> [String]
getMultipleValue hh k = map value $ getMultiple hh k

-- | fCMTP revision header
revisionHeader :: String
revisionHeader = "fCMTP-Revision"

-- | fCMTP base revision header
baseHeader :: String
baseHeader = "fCMTP-Revision-Base"

-- | fCMTP resource URI header
addressHeader :: String
addressHeader = "fCMTP-Address"

-- | Retrieves the meta information from resource headers
resourceInfo :: PlainHeaders -> ResourceInfo
resourceInfo (PlainHeaders _ ss _) = let
  (mimet, mimep) = fromMaybe (def, def) $ getHeaderValue ss Mime.contentTypeHeaderName >>= bparse PMime.parseContentType
  curr = fromMaybe URI.NoRevision $ URI.Revision <$> getHeaderValue ss revisionHeader
  bb = map URI.Revision $ getMultipleValue ss baseHeader
  uu = catMaybes . map (bparse URI.parseURI) $ getMultipleValue ss 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

-- | Retrieve MIME information from the resource headers
getMimeData :: [Header] -> (Mime.ContentTypeHeader, Mime.TransferEncoding)
getMimeData hh = (ct, te)
  where
    ct = case getHeader hh Mime.contentTypeHeaderName of
      Nothing -> def
      Just h -> case BA.parseOnly PMime.parseContentType (SC.s . value $ h) of
        Left _ -> def
        Right (ctv, ctp) -> Mime.ContentTypeHeader ctv ctp
    te = case getHeader hh Mime.transferEncodingHeaderName of
      Nothing -> def
      Just h -> case BA.parseOnly PMime.parseTransferEncoding (SC.s . value $ h) of
        Left _ -> def
        Right t -> t

-- | Recreates the original resource text for the headers
originalData :: PlainHeaders -> BS.ByteString
originalData (PlainHeaders pp ss (psep, ssep)) =
  BS.concat [
  catData pp, psep,
  catData ss, ssep
  ]
  where
    catData :: [Header] -> BS.ByteString
    catData hh = BS.concat . map bare $ hh

-- | Recreates the original resource text for the sealed headers only
originalSealed :: PlainHeaders -> BS.ByteString
originalSealed (PlainHeaders _ ss (_, ssep)) =
  (BS.concat $ map bare ss) `BS.append` ssep