Move MIME stuff into proper Codec.* namespace.

Add copyrights where missing.

6 files changed, 0 insertions, 646 deletions

diff --git a/MIME/Base64.hs b/MIME/Base64.hs
deleted file mode 100644
index 848e034..0000000
--- a/MIME/Base64.hs
+++ /dev/null
@@ -1,141 +0,0 @@
-{- |
- 
-  Module      :  MIME.Parse
-  Copyright   :  (c) 2006
-
-  Maintainer      : 
-  Stability       : unstable
-  Portability     : GHC
-  
-  Base64 decoding and encoding routines.
--}
-module MIME.Base64 
-        ( encodeRaw         -- :: Bool -> String -> [Word8]
-	, encodeRawString   -- :: Bool -> String -> String
-	, encodeRawPrim     -- :: Bool -> Char -> Char -> [Word8] -> String
-
-	, formatOutput      -- :: Int    -> Maybe String -> String -> String
-	
-	, decode            -- :: String -> [Word8]
-	, decodeToString    -- :: String -> String
-	, decodePrim        -- :: Char -> Char -> String -> [Word8]
-	) where
-
-import Data.Bits
-import Data.Char
-import Data.Word
-import Data.Maybe
-
-encodeRawString :: Bool -> String -> String
-encodeRawString trail xs = encodeRaw trail (map (fromIntegral.ord) xs)
-
--- | 'formatOutput n mbLT str' formats 'str', splitting it
--- into lines of length 'n'. The optional value lets you control what
--- line terminator sequence to use; the default is CRLF (as per MIME.)
-formatOutput :: Int -> Maybe String -> String -> String
-formatOutput n mbTerm str
- | n <= 0    = error ("formatOutput: negative line length " ++ show n)
- | otherwise = chop n str
-   where
-     crlf :: String
-     crlf = fromMaybe "\r\n" mbTerm
-
-     chop _ "" = ""
-     chop i xs =
-       case splitAt i xs of
-         (as,"") -> as
-	 (as,bs) -> as ++ crlf ++ chop i bs
-
-encodeRaw :: Bool -> [Word8] -> String
-encodeRaw trail bs = encodeRawPrim trail '+' '/' bs
-
--- lets you control what non-alphanum characters to use
--- (The base64url variation uses '*' and '-', for instance.)
--- No support for mapping these to multiple characters in the output though.
-encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String
-encodeRawPrim trail ch62 ch63 ls = encoder ls
- where
-  trailer xs ys
-   | not trail = xs
-   | otherwise = xs ++ ys
-  f = fromB64 ch62 ch63 
-  encoder []    = []
-  encoder [x]   = trailer (take 2 (encode3 f x 0 0 "")) "=="
-  encoder [x,y] = trailer (take 3 (encode3 f x y 0 "")) "="
-  encoder (x:y:z:ws) = encode3 f x y z (encoder ws)
-
-encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
-encode3 f a b c rs = 
-     f (low6 (w24 `shiftR` 18)) :
-     f (low6 (w24 `shiftR` 12)) :
-     f (low6 (w24 `shiftR` 6))  :
-     f (low6 w24) : rs
-   where
-    w24 :: Word32
-    w24 = (fromIntegral a `shiftL` 16) +
-          (fromIntegral b `shiftL` 8)  + 
- 	   fromIntegral c
-
-decodeToString :: String -> String
-decodeToString str = map (chr.fromIntegral) $ decode str
-
-decode :: String -> [Word8]
-decode str = decodePrim '+' '/' str
-
-decodePrim :: Char -> Char -> String -> [Word8]
-decodePrim ch62 ch63 str =  decoder $ takeUntilEnd str
- where
-  takeUntilEnd "" = []
-  takeUntilEnd ('=':_) = []
-  takeUntilEnd (x:xs) = 
-    case toB64 ch62 ch63 x of
-      Nothing -> takeUntilEnd xs
-      Just b  -> b : takeUntilEnd xs
-
-decoder :: [Word8] -> [Word8]
-decoder [] = []
-decoder [x] = take 1 (decode4 x 0 0 0 [])
-decoder [x,y] = take 1 (decode4 x y 0 0 []) -- upper 4 bits of second val are known to be 0.
-decoder [x,y,z] = take 2 (decode4 x y z 0 [])
-decoder (x:y:z:w:xs) = decode4 x y z w (decoder xs)
-
-decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
-decode4 a b c d rs =
-  (lowByte (w24 `shiftR` 16)) :
-  (lowByte (w24 `shiftR` 8))  :
-  (lowByte w24) : rs
- where
-  w24 :: Word32
-  w24 =
-   (fromIntegral a) `shiftL` 18 .|.
-   (fromIntegral b) `shiftL` 12 .|.
-   (fromIntegral c) `shiftL` 6  .|.
-   (fromIntegral d)
-
-toB64 :: Char -> Char -> Char -> Maybe Word8
-toB64 a b ch
-  | ch >= 'A' && ch <= 'Z' = Just (fromIntegral (ord ch - ord 'A'))
-  | ch >= 'a' && ch <= 'z' = Just (26 + fromIntegral (ord ch - ord 'a'))
-  | ch >= '0' && ch <= '9' = Just (52 + fromIntegral (ord ch - ord '0'))
-  | ch == a = Just 62
-  | ch == b = Just 63
-  | otherwise = Nothing
-
-fromB64 :: Char -> Char -> Word8 -> Char
-fromB64 ch62 ch63 x 
-  | x < 26    = chr (ord 'A' + xi)
-  | x < 52    = chr (ord 'a' + (xi-26))
-  | x < 62    = chr (ord '0' + (xi-52))
-  | x == 62   = ch62
-  | x == 63   = ch63
-  | otherwise = error ("fromB64: index out of range " ++ show x)
- where
-  xi :: Int
-  xi = fromIntegral x
-
-low6 :: Word32 -> Word8
-low6 x = fromIntegral (x .&. 0x3f)
-
-lowByte :: Word32 -> Word8
-lowByte x = (fromIntegral x) .&. 0xff
-
diff --git a/MIME/Decode.hs b/MIME/Decode.hs
deleted file mode 100644
index f23454a..0000000
--- a/MIME/Decode.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module MIME.Decode where
-
-import Data.Char
-import MIME.QuotedPrintable as QP
-import MIME.Base64 as Base64
-
-decodeBody :: String -> String -> String
-decodeBody enc body =
- case map toLower enc of
-   "base64"           -> map (chr.fromIntegral) $ Base64.decode body
-   "quoted-printable" -> QP.decode body
-   _ -> body
-
--- Decoding of RFC 2047's "encoded-words' production
--- (as used in email-headers and some HTTP header cases
--- (AtomPub's Slug: header))
-decodeWord :: String -> Maybe (String, String)
-decodeWord str =
-  case str of
-   '=':'?':xs ->
-     case dropLang $ break (\ch -> ch =='?' || ch == '*') xs of
-       (cs,_:x:'?':bs)
-         | isKnownCharset (map toLower cs) ->
-           case toLower x of
-             'q' -> decodeQ cs (break (=='?') bs)
-             'b' -> decodeB cs (break (=='?') bs)
-             _   -> Nothing
-       _ -> Nothing
-   _ -> Nothing
- where
-  isKnownCharset cs = cs `elem` ["iso-8859-1", "us-ascii"]
-
-   -- ignore RFC 2231 extension of permitting a language tag to be supplied
-   -- after the charset.
-  dropLang (as,'*':bs) = (as,dropWhile (/='?') bs)
-  dropLang (as,bs) = (as,bs)
-
-  decodeQ cset (fs,'?':'=':rs) = Just (fromCharset cset (QP.decode fs),rs)
-  decodeQ _ _ = Nothing
-
-  decodeB cset (fs,'?':'=':rs) =
-    Just (fromCharset cset (Base64.decodeToString fs),rs)
-  decodeB _ _ = Nothing
-
-  fromCharset _cset cs = cs
-
-decodeWords :: String -> String
-decodeWords "" = ""
-decodeWords (x:xs)
- | isSpace x = x : decodeWords xs
- | otherwise =
-  case decodeWord (x:xs) of
-    Nothing -> x : decodeWords xs
-    Just (as,bs) -> as ++ decodeWords bs
-
-
diff --git a/MIME/Parse.hs b/MIME/Parse.hs
deleted file mode 100644
index 06fffc6..0000000
--- a/MIME/Parse.hs
+++ /dev/null
@@ -1,241 +0,0 @@
-{- |
-  Module      :  MIME.Parse
-  Copyright   :  (c) 2006
-
-  Maintainer      : tse-dev-team@galois.com
-  Stability       : unstable
-  Portability     : GHC
-
-  Parsing MIME content.
--}
-module MIME.Parse
-  ( parseMIMEBody
-  , parseMIMEType
-  ) where
-
-import MIME.Type
-import MIME.Decode
-
-import Data.Char
-import Data.Maybe
-import Data.List
-import Debug.Trace ( trace )
-
-parseMIMEBody :: [(String,String)] -> String -> MIMEValue
-parseMIMEBody headers_in body =
-  case mimeType mty of
-    Multipart{} -> fst (parseMultipart mty body)
-    Message{}   -> fst (parseMultipart mty body)
-    _           -> MIMEValue mty (parseContentDisp headers)
-                                 (Single (processBody headers body))
-
- where headers = [ (map toLower k,v) | (k,v) <- headers_in ]
-       mty = fromMaybe defaultType
-                       (parseContentType =<< lookup "content-type" headers)
-defaultType :: Type
-defaultType = Type { mimeType   = Text "plain"
-                   , mimeParams = [("charset", "us-ascii")]
-                   }
-
-parseContentDisp :: [(String,String)] -> Maybe Disposition
-parseContentDisp headers =
-  (processDisp . dropFoldingWSP) =<< lookup "content-disposition" headers
-  where
-  processDisp "" = Nothing
-  processDisp xs = Just $
-    case break (\ch -> isSpace ch || ch == ';') xs of
-      (as,"") -> Disposition { dispType = toDispType (map toLower as)
-                             , dispParams = []
-                             }
-      (as,bs) -> Disposition { dispType = toDispType (map toLower as)
-                             , dispParams = processParams (parseParams bs)
-                             }
-
-  processParams = map procP
-    where
-    procP (as,val)
-      | "name" == asl              = Name val
-      | "filename" == asl          = Filename val
-      | "creation-date" == asl     = CreationDate val
-      | "modification-date" == asl = ModDate val
-      | "read-date" == asl         = ReadDate val
-      | "size" == asl              = Size val
-      | otherwise                  = OtherParam (map toLower as) val
-      where asl = map toLower as
-
-  toDispType t = case t of
-                   "inline"     -> DispInline
-                   "attachment" -> DispAttachment
-                   "form-data"  -> DispFormData
-                   _            -> DispOther t
-
-
-processBody :: [(String,String)] -> String -> String
-processBody headers body =
-  case lookup "content-transfer-encoding" headers of
-    Nothing -> body
-    Just v  -> decodeBody v body
-
-parseMIMEMessage :: String -> MIMEValue
-parseMIMEMessage entity =
-  case parseHeaders entity of
-   (as,bs) -> parseMIMEBody as bs
-
-parseHeaders :: String -> ([(String,String)], String)
-parseHeaders str =
-  case findFieldName "" str of
-    Left (nm, rs) -> parseFieldValue nm (dropFoldingWSP rs)
-    Right body    -> ([],body)
- where
-  findFieldName _acc "" = Right ""
-  findFieldName _acc ('\r':'\n':xs) = Right xs
-  findFieldName acc (':':xs) = Left (reverse (dropWhile isHSpace acc), xs)
-  findFieldName acc (x:xs) = findFieldName (x:acc) xs
-
-  parseFieldValue nm xs =
-    case takeUntilCRLF xs of
-      (as,"") -> ([(nm,as)],"")
-      (as,bs) -> let (zs,ys) = parseHeaders bs in ((nm,as):zs,ys)
-
-parseMultipart :: Type -> String -> (MIMEValue, String)
-parseMultipart mty body =
-  case lookup "boundary" (mimeParams mty) of
-    Nothing -> trace ("Multipart mime type, " ++ showType mty ++
-      ", has no required boundary parameter. Defaulting to text/plain") $
-      (MIMEValue defaultType Nothing (Single body), "")
-    Just bnd -> (MIMEValue mty Nothing (Multi vals), rs)
-      where (vals,rs) = splitMulti bnd body
-
-splitMulti :: String -> String -> ([MIMEValue], String)
-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 = case body_in of
-                '-':'-':_ -> ('\r':'\n':body_in)
-                _ -> body_in
-  in case untilMatch dashBoundary body of
-       Nothing           -> ([],"")
-       Just ('-':'-':xs) -> ([],xs)
-       Just xs           -> splitMulti1 (dropTrailer xs)
-
- where
-  dashBoundary = ("\r\n--" ++ bnd)
-
-  splitMulti1 xs =
-    case matchUntil dashBoundary xs of
-      ("","") -> ([],"")
-      (as,"") -> ([parseMIMEMessage as],"")
-      (as,'-':'-':bs) -> ([parseMIMEMessage as], dropTrailer bs)
-      (as,bs) -> let (zs,ys) = splitMulti1 (dropTrailer bs)
-                 in ((parseMIMEMessage as) : zs,ys)
-
-  dropTrailer xs =
-    case dropWhile isHSpace xs of
-      '\r':'\n':xs1 -> xs1
-      xs1 -> xs1 -- hmm, flag an error?
-
-parseMIMEType :: String -> Maybe Type
-parseMIMEType = parseContentType
-
-parseContentType :: String -> Maybe Type
-parseContentType str =
-   case break (=='/') (dropFoldingWSP str) of
-       (maj,_:minor) ->
-          case break (\ ch -> isHSpace ch || isTSpecial ch) minor of
-            (as,bs)  -> 
-               Just Type { mimeType = toType maj as
-                         , mimeParams = parseParams (dropWhile isHSpace bs)
-                         }
-       _ -> trace ("unable to parse content-type: " ++ show str) $ Nothing
- where
-  toType a b = case lookup (map toLower a) mediaTypes of
-                 Just ctor -> ctor b
-                 _ -> Other a b
-
-
-parseParams :: String -> [(String,String)]
-parseParams "" = []
-parseParams (';':xs) =
-    case break (=='=') (dropFoldingWSP xs) of
-      (nm,_:vs) ->
-        case vs of
-          '"':vs1 ->
-             case break (=='"') vs1 of
-               (val,"") -> [(nm,val)]
-               (val,_:zs) -> (nm,val):parseParams (dropWhile isHSpace zs)
-          _ -> case break (\ ch -> isHSpace ch || isTSpecial ch) vs of
-                 (val,zs) -> (nm,val):parseParams (dropWhile isHSpace zs)
-      _ -> []
-
-parseParams cs = trace ("curious: " ++ show cs) []
-
-mediaTypes :: [(String, String -> MIMEType)]
-mediaTypes =
-  [ ("multipart",   (Multipart . toMultipart))
-  , ("application", Application)
-  , ("audio",       Audio)
-  , ("image",       Image)
-  , ("message",     Message)
-  , ("model",       Model)
-  , ("text",        Text)
-  , ("video",       Video)
-  ]
- where toMultipart b = fromMaybe other (lookup (map toLower b) multipartTypes)
-          where other = case b of
-                          'x':'-':_ -> Extension b
-                          _ -> OtherMulti b
-
-
-multipartTypes :: [(String, Multipart)]
-multipartTypes =
-  [ ("alternative", Alternative)
-  , ("byteranges",  Byteranges)
-  , ("digest",      Digest)
-  , ("encrypted",   Encrypted)
-  , ("form-data",   FormData)
-  , ("mixed",       Mixed)
-  , ("parallel",    Parallel)
-  , ("related",     Related)
-  , ("signed",      Signed)
-  ]
-
-
-untilMatch :: String -> String -> Maybe String
-untilMatch str xs = go str xs
-  where go ""     rs      = Just rs
-        go _      ""      = Nothing
-        go (a:as) (b:bs)  = if a == b then go as bs else go str bs
-
-matchUntil :: String -> String -> (String, String)
-matchUntil _   "" = ("", "")
-matchUntil str xs
-    -- slow, but it'll do for now.
-  | str `isPrefixOf` xs = ("", drop (length str) xs)
-matchUntil str (x:xs) = let (as,bs) = matchUntil str xs in (x:as,bs)
-
-
-
-isHSpace :: Char -> Bool
-isHSpace c = c == ' ' || c == '\t'
-
-isTSpecial :: Char -> Bool
-isTSpecial x = x `elem` "()<>@,;:\\\"/[]?="
-
-
-dropFoldingWSP :: String -> String
-dropFoldingWSP "" = ""
-dropFoldingWSP (x:xs)
- | isHSpace x = dropFoldingWSP xs
-dropFoldingWSP ('\r':'\n':x:xs)
- | isHSpace x = dropFoldingWSP xs
-dropFoldingWSP (x:xs) = x:xs
-
-takeUntilCRLF :: String -> (String, String)
-takeUntilCRLF str = go "" str
- where
-  go acc "" = (reverse (dropWhile isHSpace acc), "")
-  go acc ('\r':'\n':x:xs)
-   | isHSpace x = go (' ':acc) xs
-   | otherwise  = (reverse (dropWhile isHSpace acc), x:xs)
-  go acc (x:xs) = go (x:acc) xs
-
diff --git a/MIME/QuotedPrintable.hs b/MIME/QuotedPrintable.hs
deleted file mode 100644
index 514ce4e..0000000
--- a/MIME/QuotedPrintable.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module MIME.QuotedPrintable where
-
-import Data.Char
-
-decode :: String -> String
-decode "" = ""
-decode ('=':x1:x2:xs)
- | isHexDigit x1 && isHexDigit x2 =
-    chr (digitToInt x1 * 16 + digitToInt x2) : decode xs
-decode ('=':xs) = '=':decode xs
-              -- make it explicit that we propagate other '=' occurrences.
-decode (x1:xs) = x1:decode xs
diff --git a/MIME/Type.hs b/MIME/Type.hs
deleted file mode 100644
index e9266ec..0000000
--- a/MIME/Type.hs
+++ /dev/null
@@ -1,166 +0,0 @@
-{- |
- 
-  Module      :  MIME.Type
-  Copyright   :  (c) 2006
-
-  Maintainer      : tse-dev-team@galois.com
-  Stability       : unstable
-  Portability     : GHC
-  
-  Representing MIME types and values.
--}
-module MIME.Type where
-
-import Data.List ( concatMap, isSuffixOf )
-
-data Type
- = Type
-    { mimeType   :: MIMEType
-    , mimeParams :: [(String,String)]
-    } deriving ( Show, Ord, Eq )
-
-showType :: Type -> String
-showType t = showMIMEType (mimeType t) ++ showMIMEParams (mimeParams t)
-
-showMIMEParams :: [(String,String)] -> String
-showMIMEParams ps = concatMap showP ps
- where 
-  showP (a,b) = ';':a ++ '=':'"':b ++ "\""
-
-
-data MIMEType
- = Application SubType
- | Audio       SubType
- | Image       SubType
- | Message     SubType
- | Model       SubType
- | Multipart   Multipart
- | Text        TextType
- | Video       SubType
- | Other       String SubType
-   deriving ( Show, Ord, Eq )
-
-showMIMEType :: MIMEType -> String
-showMIMEType t = 
- case t of
-   Application s -> "application/"++s
-   Audio s       -> "audio/"++s
-   Image s       -> "image/"++s
-   Message s     -> "message/"++s
-   Model s       -> "model/"++s
-   Multipart s   -> "multipart/"++showMultipart s
-   Text s        -> "text/"++s
-   Video s       -> "video/"++s
-   Other a b     -> a ++ '/':b
-
--- | a (type, subtype) MIME pair.
-data MIMEPair
- = MIMEPair String SubType
-   deriving ( Eq )
-
-showMIMEPair :: MIMEPair -> String
-showMIMEPair (MIMEPair a b) = a ++ '/':b
-
--- | default subtype representation.
-type SubType = String
-
--- | subtype for text content; currently just a string.
-type TextType = SubType
-
-subTypeString :: Type -> String
-subTypeString t = 
-  case break (=='/') (showMIMEType (mimeType t)) of
-   (_,"") -> ""
-   (_,_:bs) -> bs
-
-majTypeString :: Type -> String
-majTypeString t = 
-  case break (=='/') (showMIMEType (mimeType t)) of
-   (as,_) -> as
-
-data Multipart
- = Alternative
- | Byteranges
- | Digest
- | Encrypted
- | FormData
- | Mixed
- | Parallel
- | Related
- | Signed
- | Extension  String  -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit)
- | OtherMulti String  -- unrecognized\/uninterpreted.
-                      -- (e.g., appledouble, voice-message, etc.)
-   deriving ( Show, Ord, Eq )
-
-isXmlBased :: Type -> Bool
-isXmlBased t = 
-  case mimeType t of
-     Multipart{} -> False
-     _ -> "+xml" `isSuffixOf` subTypeString t
-
-isXmlType :: Type -> Bool
-isXmlType t = isXmlBased t ||
-  case mimeType t of
-    Application s -> s `elem` xml_media_types
-    Text s        -> s `elem` xml_media_types
-    _             -> False
- where
-    -- Note: xml-dtd isn't considered an XML type here.
-  xml_media_types :: [String]
-  xml_media_types = 
-    [ "xml"
-    , "xml-external-parsed-entity"
-    ]
-  
-
-showMultipart :: Multipart -> String
-showMultipart m = 
- case m of
-   Alternative -> "alternative"
-   Byteranges  -> "byteranges"
-   Digest      -> "digest"
-   Encrypted   -> "encrypted"
-   FormData    -> "form-data"
-   Mixed       -> "mixed"
-   Parallel    -> "parallel"
-   Related     -> "related"
-   Signed      -> "signed"
-   Extension e -> e
-   OtherMulti e -> e
-   
-type Content = String
-
-data MIMEValue = MIMEValue {
-  mime_val_type :: Type,
-  mime_val_disp :: Maybe Disposition,
-  mime_val_content :: MIMEContent }
-  deriving ( Show, Eq )
-
-data MIMEContent 
-  = Single Content
-  | Multi [MIMEValue]
-    deriving (Eq,Show)
-   
-data Disposition
- = Disposition
-     { dispType   :: DispType
-     , dispParams :: [DispParam]
-     } deriving ( Show, Eq )
-
-data DispType
- = DispInline
- | DispAttachment
- | DispFormData
- | DispOther String
-   deriving ( Show, Eq)
-
-data DispParam
- = Name String
- | Filename String
- | CreationDate String
- | ModDate String
- | ReadDate String
- | Size String
- | OtherParam String String
-   deriving ( Show, Eq)
diff --git a/MIME/Utils.hs b/MIME/Utils.hs
deleted file mode 100644
index a5db2d9..0000000
--- a/MIME/Utils.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{- |
-  Module      :  MIME.Utils
-  Copyright   :  (c) 2007
-
-  Maintainer      : tse-dev-team@galois.com
-  Stability       : unstable
-  Portability     : GHC
-
-  Extracting content from MIME values and types.
--}
-module MIME.Utils
-  ( findMultipartNamed -- :: String -> MIMEValue -> Maybe MIMEValue
-  )  where
-
-import MIME.Type
-import Data.List ( find )
-import Control.Monad ( msum )
-
--- | Given a parameter name, locate it within a MIME value,
--- returning the corresponding (sub) MIME value.
-findMultipartNamed :: String -> MIMEValue -> Maybe MIMEValue
-findMultipartNamed nm mv =
- case mime_val_content mv of
-   Multi ms  -> msum (map (findMultipartNamed nm) ms)
-   Single {} -> do cd <- mime_val_disp mv
-                   find (withDispName nm) (dispParams cd)
-                   return mv
- where withDispName a (Name b) = a == b
-       withDispName _ _ = False
-