1 files changed, 189 insertions, 0 deletions
diff --git a/src/Codec/MIME/Type.hs b/src/Codec/MIME/Type.hs
new file mode 100644
index 0000000..72ec94f
--- /dev/null
+++ b/src/Codec/MIME/Type.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE OverloadedStrings #-}
+--------------------------------------------------------------------
+-- |
+-- Module    : Codec.MIME.Type
+-- Copyright : (c) 2006-2009, Galois, Inc. 
+-- License   : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- 
+-- Representing MIME types and values.
+-- 
+--------------------------------------------------------------------
+module Codec.MIME.Type where
+
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import Data.Monoid ((<>))
+
+data MIMEParam = MIMEParam  { paramName     :: CI T.Text
+                            , paramValue    :: T.Text }
+    deriving (Show, Ord, Eq)
+
+data Type = Type
+    { mimeType   :: MIMEType
+    , mimeParams :: [MIMEParam]
+    } deriving ( Show, Ord, Eq )
+
+-- | The @null@ MIME record type value; currently a @text/plain@.
+nullType :: Type
+nullType = Type
+    { mimeType   = Text "plain"
+    , mimeParams = []
+    }
+
+showType :: Type -> T.Text
+showType t = showMIMEType (mimeType t) <> showMIMEParams (mimeParams t)
+
+showMIMEParams :: [MIMEParam] -> T.Text
+showMIMEParams ps = T.concat $ map showP ps
+  where 
+    showP (MIMEParam k v) = "; " <> CI.original k <> "=\"" <> v <> "\""
+
+
+data MIMEType
+ = Application SubType
+ | Audio       SubType
+ | Image       SubType
+ | Message     SubType
+ | Model       SubType
+ | Multipart   Multipart
+ | Text        TextType
+ | Video       SubType
+ | Other       {otherType :: CI T.Text, otherSubType :: SubType}
+   deriving ( Show, Ord, Eq )
+
+showMIMEType :: MIMEType -> T.Text
+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     -> CI.original a <> "/" <> b
+
+-- | a (type, subtype) MIME pair.
+data MIMEPair
+ = MIMEPair T.Text SubType
+   deriving ( Eq )
+
+showMIMEPair :: MIMEPair -> T.Text
+showMIMEPair (MIMEPair a b) = a <> "/" <> b
+
+-- | default subtype representation.
+type SubType = T.Text
+
+-- | subtype for text content; currently just a string.
+type TextType = SubType
+
+subTypeString :: Type -> T.Text
+subTypeString t = T.drop 1 $ snd $ T.break (=='/') (showMIMEType (mimeType t))
+
+majTypeString :: Type -> T.Text
+majTypeString t = fst $ T.break (=='/') (showMIMEType (mimeType t))
+
+data Multipart
+ = Alternative
+ | Byteranges
+ | Digest
+ | Encrypted
+ | FormData
+ | Mixed
+ | Parallel
+ | Related
+ | Signed
+ | Extension  T.Text  -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit)
+ | OtherMulti T.Text  -- unrecognized\/uninterpreted.
+                      -- (e.g., appledouble, voice-message, etc.)
+   deriving ( Show, Ord, Eq )
+
+isXmlBased :: Type -> Bool
+isXmlBased t = 
+  case mimeType t of
+     Multipart{} -> False
+     _ -> "+xml" `T.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 :: [T.Text]
+  xml_media_types = 
+    [ "xml"
+    , "xml-external-parsed-entity"
+    ]
+  
+
+showMultipart :: Multipart -> T.Text
+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 = T.Text
+
+data MIMEValue = MIMEValue
+      { mime_val_type     :: Type
+      , mime_val_disp     :: Maybe Disposition
+      , mime_val_content  :: MIMEContent
+      , mime_val_headers  :: [MIMEParam]
+      , mime_val_inc_type :: Bool
+      } deriving ( Show, Eq )
+
+nullMIMEValue :: MIMEValue
+nullMIMEValue = MIMEValue
+      { mime_val_type     = nullType
+      , mime_val_disp     = Nothing
+      , mime_val_content  = Multi []
+      , mime_val_headers  = []
+      , mime_val_inc_type = True
+      } 
+
+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 T.Text
+   deriving ( Show, Eq)
+
+data DispParam
+ = Name T.Text
+ | Filename T.Text
+ | CreationDate T.Text
+ | ModDate T.Text
+ | ReadDate T.Text
+ | Size T.Text
+ | OtherParam (CI T.Text) T.Text
+   deriving ( Show, Eq)