path: root/src/Codec/MIME/Parse.hs

{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------
-- |
-- Module    : Codec.MIME.Pare
-- Copyright : (c) 2006-2009, Galois, Inc. 
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
-- Stability : provisional
-- Portability: portable
--
-- Parsing MIME content.
-- 
--------------------------------------------------------------------
module Codec.MIME.Parse
  ( parseMIMEBody    -- :: [(T.Text,T.Text)] -> T.Text -> MIMEValue
  , parseMIMEType    -- :: T.Text -> Maybe Type
  , parseMIMEMessage -- :: T.Text -> MIMEValue

  , parseHeaders     -- :: T.Text -> ([(T.Text,T.Text)], T.Text)
  , parseMultipart   -- :: Type -> T.Text -> (MIMEValue, T.Text)
  , parseContentType -- :: T.Text -> Maybe Type
  , splitMulti       -- :: T.Text -> T.Text -> ([MIMEValue], T.Text)
  , normalizeCRLF
  ) where

import Codec.MIME.Type
import Codec.MIME.Decode
import Control.Arrow(second)

import           Data.CaseInsensitive   (CI)
import qualified Data.CaseInsensitive as CI
import Data.Char
import Data.Maybe
import qualified Data.List as L
import Debug.Trace ( trace )
import qualified Data.Text as T
import Data.Monoid(Monoid(..), (<>))

enableTrace :: Bool
enableTrace = False

doTrace :: String -> b -> b
doTrace | enableTrace = trace
        | otherwise   = \_ x -> x


parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue
parseMIMEBody headers body = result { mime_val_headers = headers }
  where
  result = case mimeType mty of
    Multipart{} -> fst (parseMultipart mty body)
    Message{}   -> fst (parseMultipart mty body)
    _           -> nullMIMEValue { mime_val_type    = mty
                                 , mime_val_disp    = parseContentDisp headers
                                 , mime_val_content = Single (processBody headers body)
                                 }
  mty = fromMaybe defaultType
                       (parseContentType =<< lookupField "content-type" (paramPairs headers))
defaultType :: Type
defaultType = Type { mimeType   = Text "plain"
                   , mimeParams = [MIMEParam "charset" "us-ascii"]
                   }

parseContentDisp :: [MIMEParam] -> Maybe Disposition
parseContentDisp headers =
    (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" (paramPairs headers)
  where
    processDisp t | T.null t  = Nothing
                  | T.null bs = Just $ Disposition { dispType = toDispType as
                                                   , dispParams = []
                                                   }
                  | otherwise = Just $ Disposition { dispType = toDispType as
                                                   , dispParams = processParams (parseParams bs)
                                                   } 
      where (as,bs) = T.break (\ch -> isSpace ch || ch == ';') t

    processParams = map procP
      where
        procP (MIMEParam k val)
            | "name" == k              = Name val
            | "filename" == k          = Filename val
            | "creation-date" == k     = CreationDate val
            | "modification-date" == k = ModDate val
            | "read-date" == k         = ReadDate val
            | "size" == k              = Size val
            | otherwise                = OtherParam k val

    toDispType t = if t == "inline" then DispInline
                   else if t == "attachment" then DispAttachment
                   else if t == "form-data"  then DispFormData
                   else  DispOther t

paramPairs :: [MIMEParam] -> [(CI T.Text, T.Text)]
paramPairs = map paramPair
  where
    paramPair (MIMEParam a b) = (a,b)

processBody :: [MIMEParam] -> T.Text -> T.Text
processBody headers body =
  case lookupField "content-transfer-encoding" $ paramPairs headers of
    Nothing -> body
    Just v  -> T.pack $ decodeBody (T.unpack v) $ T.unpack body

normalizeCRLF :: T.Text -> T.Text
normalizeCRLF t
    | T.null t = ""
    | "\r\n" `T.isPrefixOf` t = "\r\n" <> normalizeCRLF (T.drop 2 t)
    | any (`T.isPrefixOf` t) ["\r", "\n"] = "\r\n" <> normalizeCRLF (T.drop 1 t)
    | otherwise = let (a,b) = T.break (`elem` ("\r\n" :: String)) t in a <> normalizeCRLF b
  
parseMIMEMessage :: T.Text -> MIMEValue
parseMIMEMessage entity =
  case parseHeaders (normalizeCRLF entity) of
   (as,bs) -> parseMIMEBody as bs

parseHeaders :: T.Text -> ([MIMEParam], T.Text)
parseHeaders str =
  case findFieldName "" str of
    Left (nm, rs) -> parseFieldValue (CI.mk nm) (dropFoldingWSP rs)
    Right body    -> ([],body)
 where
  findFieldName acc t 
    | T.null t = Right ""
    | "\r\n" `T.isPrefixOf` t = Right $ T.drop 2 t
    | ":" `T.isPrefixOf` t = Left (T.reverse $ T.dropWhile isHSpace acc, T.drop 1 t)
    | otherwise = findFieldName (T.take 1 t <> acc) $ T.drop 1 t

  parseFieldValue nm xs 
      | T.null bs = ([MIMEParam nm as], "")
      | otherwise = let (zs,ys) = parseHeaders bs in (MIMEParam nm as :zs, ys)
    where 
      (as,bs) = takeUntilCRLF xs

parseMultipart :: Type -> T.Text -> (MIMEValue, T.Text)
parseMultipart mty body =
  case lookupField "boundary" (paramPairs $ mimeParams mty) of
    Nothing -> doTrace ("Multipart mime type, " ++ T.unpack (showType mty) ++
      ", has no required boundary parameter. Defaulting to text/plain") $
      (nullMIMEValue{ mime_val_type = defaultType
                    , mime_val_disp = Nothing
                    , mime_val_content = Single body
                    }, "")
    Just bnd -> (nullMIMEValue { mime_val_type = mty
                               , mime_val_disp = Nothing
                               , mime_val_content = Multi vals
                               }, rs)
      where (vals,rs) = splitMulti bnd body

splitMulti :: T.Text -> T.Text -> ([MIMEValue], T.Text)
splitMulti bnd body_in =
  -- Note: we insert a CRLF if it looks as if the boundary string starts
  -- right off the bat.  No harm done if this turns out to be incorrect.
  let body | "--" `T.isPrefixOf` body_in = "\r\n" <> body_in
           | otherwise  = body_in
  in case untilMatch dashBoundary body of
       Nothing           -> mempty
       Just xs  | "--" `T.isPrefixOf` xs    -> ([], T.drop 2 xs)
                | otherwise                 -> splitMulti1 (dropTrailer xs)

 where
  dashBoundary = ("\r\n--" <> bnd)

  splitMulti1 xs 
      | T.null as && T.null bs = ([], "")
      | T.null bs = ([parseMIMEMessage as],"")
      | T.isPrefixOf "--" bs    =  ([parseMIMEMessage as], dropTrailer bs)
      | otherwise   = let (zs,ys) = splitMulti1 (dropTrailer bs)
                            in ((parseMIMEMessage as) : zs,ys)

    where
      (as,bs) = matchUntil dashBoundary xs

  dropTrailer xs 
      | "\r\n" `T.isPrefixOf` xs1 = T.drop 2 xs1
      | otherwise   = xs1 -- hmm, flag an error?
    where
       xs1 = T.dropWhile isHSpace xs 

parseMIMEType :: T.Text -> Maybe Type
parseMIMEType = parseContentType

parseContentType :: T.Text -> Maybe Type
parseContentType str
    | T.null minor0 = doTrace ("unable to parse content-type: " ++ show str) $ Nothing
    | otherwise     = Just Type  { mimeType = toType (CI.mk maj) as
                                 , mimeParams = parseParams (T.dropWhile isHSpace bs)
                                 }
  where
    (maj, minor0) = T.break (=='/') (dropFoldingWSP str)
    minor = T.drop 1 minor0
    (as, bs) = T.break (\ ch -> isHSpace ch || isTSpecial ch) minor 
    toType a b = case lookupField a mediaTypes of
         Just ctor -> ctor b
         _ -> Other a b

parseParams :: T.Text -> [MIMEParam]
parseParams t   | T.null t          = []
                | ';' == T.head t   = let (nm_raw, vs0) = T.break (=='=') (dropFoldingWSP $ T.tail t) 
                                          nm = CI.mk nm_raw in
                    if T.null vs0 
                        then []
                        else let vs = T.tail vs0 in
                            if not (T.null vs) && T.head vs == '"' 
                                then let vs1 = T.tail vs 
                                         (val, zs0) = T.break (=='"') vs1 in
                                    if T.null zs0 
                                        then [MIMEParam nm val]
                                        else MIMEParam nm val : parseParams (T.dropWhile isHSpace $ T.tail zs0)
                                else let (val, zs) = T.break (\ch -> isHSpace ch || isTSpecial ch) vs in
                                    MIMEParam nm val : parseParams (T.dropWhile isHSpace zs)
                | otherwise = doTrace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ show t) []

mediaTypes :: [(CI T.Text, T.Text -> MIMEType)]
mediaTypes =
  [ ("multipart",   (Multipart . toMultipart))
  , ("application", Application)
  , ("audio",       Audio)
  , ("image",       Image)
  , ("message",     Message)
  , ("model",       Model)
  , ("text",        Text)
  , ("video",       Video)
  ]
 where toMultipart b = fromMaybe other (lookupField (CI.mk b) multipartTypes)
          where other | T.isPrefixOf "x-" b = Extension b
                      | otherwise           = OtherMulti b

multipartTypes :: [(CI T.Text, Multipart)]
multipartTypes =
  [ ("alternative", Alternative)
  , ("byteranges",  Byteranges)
  , ("digest",      Digest)
  , ("encrypted",   Encrypted)
  , ("form-data",   FormData)
  , ("mixed",       Mixed)
  , ("parallel",    Parallel)
  , ("related",     Related)
  , ("signed",      Signed)
  ]

untilMatch :: T.Text -> T.Text -> Maybe T.Text
untilMatch a b  | T.null a  = Just b
                | T.null b  = Nothing
                | a `T.isPrefixOf` b = Just $ T.drop (T.length a) b
                | otherwise = untilMatch a $ T.tail b

matchUntil :: T.Text -> T.Text -> (T.Text, T.Text)
-- searching str; returning parts before str and after str
matchUntil str = second (T.drop $ T.length str) . T.breakOn str

{-
matchUntil' :: T.Text -> T.Text -> (T.Text, T.Text)
matchUntil' _   "" = ("", "")
matchUntil' str xs
    | T.null xs = mempty
    -- slow, but it'll do for now.
    | str `T.isPrefixOf` xs = ("", T.drop (T.length str) xs)
    | otherwise = let (as,bs) = matchUntil' str $ T.tail xs in (T.take 1 xs <> as, bs)
-}

isHSpace :: Char -> Bool
isHSpace c = c == ' ' || c == '\t'

isTSpecial :: Char -> Bool
isTSpecial x = x `elem` ("()<>@,;:\\\"/[]?=" :: String) -- "

dropFoldingWSP :: T.Text -> T.Text
dropFoldingWSP t | T.null t   = ""
                 | isHSpace (T.head t) = dropFoldingWSP $ T.tail t
                 | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t) 
                    = dropFoldingWSP $ T.drop 3 t
                 | otherwise    = t 

takeUntilCRLF :: T.Text -> (T.Text, T.Text)
takeUntilCRLF str = go "" str
 where
  go acc t  | T.null t  = (T.reverse (T.dropWhile isHSpace acc), "")
            | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t)  
                        = go (" " <> acc) (T.drop 3 t)
            | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t)  
                        = (T.reverse (T.dropWhile isHSpace acc), T.drop 2 t)
            | otherwise = go (T.take 1 t <> acc) $ T.tail t

-- case in-sensitive lookup of field names or attributes\/parameters.
lookupField :: CI T.Text -> [(CI T.Text,a)] -> Maybe a
lookupField n ns = 
   -- assume that inputs have been mostly normalized already 
   -- (i.e., lower-cased), but should the lookup fail fall back
   -- to a second try where we do normalize before giving up.
  case lookup n ns of
    x@Just{} -> x
    Nothing  -> 
      fmap snd $ L.find ((n==) . fst) ns