Adaptations for warus spools

fcmtp-data.cabal

@@ -58,4 +58,4 @@ library
         Data.SMTP.Types.Address Data.SMTP.Parser.Address
         Data.SMTP.Types.URI Data.SMTP.Parser.URI,
         Data.SMTP.Crypto.Types.CP, Data.SMTP.Crypto.Algos.CP
-    ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded
+    ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns

src/Data/SMTP/Mime.hs

@@ -15,14 +15,15 @@ import Data.SMTP.Parser.Mime
 import Data.SMTP.Types.Resource
 import Data.SMTP.Parser.Resource
 
-import Text.StringConvert
+--import Text.StringConvert
+import qualified Text.StringConvert as SC
 
 import qualified Data.Attoparsec.ByteString.Char8.Extras as P
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.Char as C
 import Data.ByteString (ByteString)
 import Data.Word8 (Word8)
-import qualified Data.Word8 as W
+--import qualified Data.Word8 as W
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as LBS
@@ -30,21 +31,7 @@ import qualified Data.ByteString.Base64.Lazy as B64
 import qualified Data.ByteString.Lazy.Search as LSearch
 --import qualified Data.ByteString.Search as SSearch
 
-import Data.Default.Class
-
-getMimeData :: [Header] -> (ContentTypeHeader, TransferEncoding)
-getMimeData hh = (ct, te)
-  where
-    ct = case getHeader hh contentTypeHeaderName of
-      Nothing -> def
-      Just (Header (_, cth)) -> case A.parseOnly parseContentType (s cth) of
-        Left _ -> def
-        Right (ctv, ctp) -> ContentTypeHeader ctv ctp
-    te = case getHeader hh transferEncodingHeaderName of
-      Nothing -> def
-      Just (Header (_, teh)) -> case A.parseOnly parseTransferEncoding (C8.pack teh) of
-        Left _ -> def
-        Right t -> t
+--import Data.Default.Class
 
 {- |
 Required encoding for the given data.
@@ -73,13 +60,13 @@ requiredEncoding dt = case requiredFeatures 0 $ LBS.unpack dt of
 
 reencodeMessage :: BodyEncoding -> ResourceData -> ResourceData
 reencodeMessage toEncoding dt = LBS.concat [
-  if newEncoding == fromEncoding then LBS.fromStrict $ BS.concat dthh else replaceEncodingHeader newEncoding dthh,
+  if newEncoding == fromEncoding then LBS.fromStrict $ originalData hh else replaceEncodingHeader newEncoding hh,
   "\r\n",
   reencodeBody'
   ]
   where
-    (dthh, hh, dtb) = takeHeaders dt
-    (ct, fromEncoding) = getMimeData hh
+    (hh, dtb) = takeHeaders dt
+    (ct, fromEncoding) = getMimeData . public $ hh
     fromEncoding' = transferToBody fromEncoding
     (message, multiPart, separator) = case ct of
       (ContentTypeHeader (MultiPartMime _) (ContentTypeParameters (Just sep) _ _)) -> (False, True, C8.pack sep)
@@ -128,19 +115,11 @@ concatParts sep = joinChunks (LBS.fromStrict sep)
     joinChunks sep' [c1, c2] = LBS.concat [c1, "\r\n--", sep', "--\r\n", c2]
     joinChunks sep' (c:cc2) = LBS.concat [c, "\r\n--", sep', "\r\n", joinChunks sep' cc2]
 
-replaceEncodingHeader :: TransferEncoding -> [ByteString] -> LBS.ByteString
-replaceEncodingHeader enc = LBS.concat . map LBS.fromStrict . echoAndReplace
+replaceEncodingHeader :: TransferEncoding -> PlainHeaders -> LBS.ByteString
+replaceEncodingHeader enc hh = LBS.fromStrict . originalData $ hh{public = map replaceHeader . public $ hh}
   where
-    h = transferEncodingHeaderName
-    echoAndReplace [] = []
-    echoAndReplace (l:ll) = if isPrefixCI h l
-                            then BS.concat [C8.pack h, ": ", C8.pack . show $ enc, "\r\n"] :
-                                 dropWhile (\x -> BS.null x || (W.isSpace . BS.head $ x)) ll
-                            else l : echoAndReplace ll
-                                 
-
-isPrefixCI :: String -> ByteString -> Bool
-isPrefixCI [] _ = True
-isPrefixCI (c:cc) bs = case BS.uncons bs of
-  Nothing -> False
-  Just (h, t) -> (C.toUpper . C.chr . fromIntegral $ h) == C.toUpper c && isPrefixCI cc t
+    k = transferEncodingHeaderName
+    replaceHeader h = if hasKey k h
+                      then Header{key=k, value=show enc,
+                                  bare = BS.concat [SC.s k, ": ", SC.s . show $ enc, "\r\n"]}
+                      else h

src/Data/SMTP/Parser/Resource.hs

@@ -4,10 +4,12 @@
 module Data.SMTP.Parser.Resource (takeHeaders, parseHeaders) where
 
 import Data.SMTP.Types.Resource
+import qualified Data.SMTP.Types.Mime as Mime
 import Text.StringConvert
 
 import Control.Applicative ((<|>))
 import Control.Monad
+import Data.Default.Class
 import Data.Attoparsec.ByteString.Char8
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.Attoparsec.ByteString.Lazy as Alz
@@ -26,23 +28,32 @@ Returns: (headers data, headers, body)
 Notice that this function chomps the lone CRLF
 that separates the body from the headers.
 -}
-takeHeaders :: ResourceData -> ([ByteString], [Header], ResourceData)
-takeHeaders dt = case Alz.parse parseHeadersAndReturn dt of
-  Alz.Fail{} -> ([], [], dt)
-  Alz.Done dtb (dth, hh) -> (dth, hh, dtb)
+takeHeaders :: ResourceData -> (PlainHeaders, ResourceData)
+takeHeaders dt = case Alz.parse parseHeaders dt of
+  Alz.Fail{} -> (def, dt)
+  Alz.Done dtb hh -> (hh, dtb)
 
 
-parseHeaders :: Parser [Header]
-parseHeaders = snd <$> parseHeadersAndReturn
+parseHeaders :: Parser PlainHeaders
+parseHeaders = do
+  (pp, psep) <- parseHeadersGroup
+  let (Mime.ContentTypeHeader ct _) = (fst $ getMimeData pp)
+  if ct == Mime.MessageMime Mime.FcmtpResource
+    then do
+    -- Has sealed headers
+    (ss, ssep) <- parseHeadersGroup
+    return $ PlainHeaders pp ss (psep, ssep)
+    else
+    return $ PlainHeaders pp [] (psep, "")
 
-parseHeadersAndReturn :: Parser ([ByteString], [Header])
-parseHeadersAndReturn = (
-  blankLine >> return ([], [])
+parseHeadersGroup :: Parser ([Header], ByteString)
+parseHeadersGroup = (
+  blankLine >>= (\l -> return ([], l))
   ) <|> (
   do
-    (dth, h) <- headerAndReturn
-    (dthh, hh) <- parseHeadersAndReturn
-    return (dth:dthh, h:hh)
+    h <- header
+    (hh, l) <- parseHeadersGroup
+    return (h:hh, l)
   )
 
 -- header :: Parser Header
@@ -56,16 +67,17 @@ parseHeadersAndReturn = (
 --   let value' = s . BS.reverse . (BS.dropWhile A.isEndOfLine) . BS.reverse $ value
 --   return $ Header (key', value')
 
-headerAndReturn :: Parser (ByteString, Header)
-headerAndReturn = do
-  key <- A.takeTill (== ':')
+header :: Parser Header
+header = do
+  k <- A.takeTill (\x -> elem x [':', '\r', '\n']) -- OverloadedStrings!
   char ':'
-  when (BS.null key) $ fail "email header must have a name"
+  when (BS.null k) $ fail "email header must have a name"
   sp <- A.takeWhile isSpace
-  value <- scan Value headerValueScanner
-  let key' = s . BS.reverse . BS.dropWhile W.isSpace . BS.reverse . BS.dropWhile W.isSpace $ key
-  let value' = s . BS.reverse . BS.dropWhile A.isEndOfLine . BS.reverse $ value
-  return (BS.concat [key, sp, value], Header (key', value'))
+  v <- scan Value headerValueScanner
+  let k' = s . BS.reverse . BS.dropWhile W.isSpace . BS.reverse . BS.dropWhile W.isSpace $ k
+  let v' = s . BS.reverse . BS.dropWhile A.isEndOfLine . BS.reverse $ v
+  let b = BS.concat [k, ":", sp, v]
+  return $ Header k' v' b
 
 data HeaderScanStatus = Value | CR | LF
 
@@ -79,7 +91,7 @@ headerValueScanner CR c
   | c == '\n' = Just LF
   | otherwise = Nothing
 headerValueScanner LF c
-  | isHorizontalSpace . fromIntegral .C.ord $ c = Just Value
+  | isHorizontalSpace . fromIntegral . C.ord $ c = Just Value
   | otherwise = Nothing
 
 blankLine :: Parser ByteString

src/Data/SMTP/Types/Resource.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Data.SMTP.Types.Resource where
 
 import qualified Data.SMTP.URI as URI
@@ -5,15 +7,19 @@ 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 Data.Char
+import qualified Data.Char as C
 
-data Header = Header (String, String) deriving (Read, Show, Eq, Ord)
+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,
@@ -27,41 +33,80 @@ instance Default ResourceInfo where
 
 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 [] _ = Nothing
-getHeader (h@(Header (hk, _)) : hh) k
-  | map toLower hk == map toLower k = Just h
-  | otherwise = getHeader hh k
+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 h = case getHeader hh h of
-  Just (Header (_, v)) -> Just v
-  Nothing -> Nothing
+getHeaderValue hh k = value <$> getHeader hh k
 
+-- | Retrieves all headers that match the key
 getMultiple :: [Header] -> String -> [Header]
-getMultiple hh h = filter (\(Header (k, _)) -> k == h) hh
+getMultiple hh k = filter (hasKey k) hh
 
+-- | Retrieves all the values of the headers that match the key
 getMultipleValue :: [Header] -> String -> [String]
-getMultipleValue hh = map (\(Header (_, v)) -> v) . getMultiple hh
+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"
 
-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
+-- | 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

src/Data/SMTP/Types/URI.hs

@@ -25,6 +25,7 @@ Returns the entire path of the URI, except for the leading slash (/).
 relativePath :: URI -> String
 relativePath URI{path=Path p} = intercalate "/" . map uriEncode $ drop 1 p
 
+-- | Entire textual representation of the URI
 fullURI :: URI -> String
 fullURI u@(URI{account=a, revision=r, parameters=pp}) =
   concat $ ["FCMTP://", s . fullAccount $ a, fullPath u] ++ (
@@ -45,6 +46,7 @@ uriEncode = N.escapeURIString N.isUnescapedInURIComponent
 instance Show URI where
   show = fullURI
 
+-- | Retrieves a parameter from the URI by key name
 getParameter :: String -> URI -> Maybe String
 getParameter p u = case map (\(Parameter _ vl) -> vl) .
                         filter (\(Parameter nm _) -> nm == p) $
@@ -52,3 +54,11 @@ getParameter p u = case map (\(Parameter _ vl) -> vl) .
                      [] -> Nothing
                      (v:_) -> Just v
 
+-- | Return revision string or a default value
+fromRevision :: String -> Revision -> String
+fromRevision d NoRevision = d
+fromRevision _ (Revision r) = r
+
+-- | Appends a new segment at the end of the path
+appendPath :: Path -> String -> Path
+appendPath (Path pp) e = Path $ pp ++ [e]