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 Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Base64.URL as Base64url
import qualified Text.StringConvert as SC
import Text.Read (readMaybe)

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 == (map C.toLower $ 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 the value of a boolean header,
accepting the common true strings:
true, t, yes, y, 1
-}
getBooleanHeader :: [Header] -> String -> Maybe Bool
getBooleanHeader hh s = (\k -> map C.toLower k `elem` ["true", "t", "yes", "y", "1"]) <$> getHeaderValue hh s

-- | Retrieves the binary value of a base64 encoded header
getBase64Header :: [Header] -> String -> Maybe BS.ByteString
getBase64Header hh s = getHeaderValue hh s >>= (rightToJust . Base64.decode . SC.s)
  where
    rightToJust = either (\_ -> Nothing) Just

-- | Retrieves the binary value of a base64url encoded header
getBase64urlHeader :: [Header] -> String -> Maybe BS.ByteString
getBase64urlHeader hh s = getHeaderValue hh s >>= (rightToJust . Base64url.decode . SC.s)
  where
    rightToJust = either (\_ -> Nothing) Just

-- | Gets the reader value, and converts it with readMaybe
getReadHeader :: Read a => [Header] -> String -> Maybe a
getReadHeader hh s = getHeaderValue hh s >>= readMaybe

-- | 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: "fCMTP-Revision"
revisionHeader :: String
revisionHeader = "fCMTP-Revision"

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

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

-- | Retrieves the meta information from resource headers
resourceInfo :: PlainHeaders -> ResourceInfo
resourceInfo (PlainHeaders pp 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 pp 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