-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.DOM.MimeTypes
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   mime type related data and functions

-}

-- ------------------------------------------------------------

module Text.XML.HXT.DOM.MimeTypes
where

import           Control.Monad          ( mplus )

import qualified Data.ByteString        as B
import qualified Data.ByteString.Char8  as C

import           Data.Char
import           Data.List
import qualified Data.Map               as M
import           Data.Maybe

import           Text.XML.HXT.DOM.MimeTypeDefaults

-- ------------------------------------------------------------

type MimeTypeTable      = M.Map String String

-- ------------------------------------------------------------

-- mime types
--
-- see RFC \"http:\/\/www.rfc-editor.org\/rfc\/rfc3023.txt\"

application_xhtml,
 application_xml,
 application_xml_external_parsed_entity,
 application_xml_dtd,
 text_html,
 text_pdf,
 text_plain,
 text_xdtd,
 text_xml,
 text_xml_external_parsed_entity        :: String

application_xhtml                       = "application/xhtml+xml"
application_xml                         = "application/xml"
application_xml_external_parsed_entity  = "application/xml-external-parsed-entity"
application_xml_dtd                     = "application/xml-dtd"

text_html                               = "text/html"
text_pdf                                = "text/pdf"
text_plain                              = "text/plain"
text_xdtd                               = "text/x-dtd"
text_xml                                = "text/xml"
text_xml_external_parsed_entity         = "text/xml-external-parsed-entity"

isTextMimeType                          :: String -> Bool
isTextMimeType                          = ("text/" `isPrefixOf`)

isHtmlMimeType                          :: String -> Bool
isHtmlMimeType t                        = t == text_html

isXmlMimeType                           :: String -> Bool
isXmlMimeType t                         = ( t `elem` [ application_xhtml
                                                     , application_xml
                                                     , application_xml_external_parsed_entity
                                                     , application_xml_dtd
                                                     , text_xml
                                                     , text_xml_external_parsed_entity
                                                     , text_xdtd
                                                     ]
                                            ||
                                            "+xml" `isSuffixOf` t               -- application/mathml+xml
                                          )                                     -- or image/svg+xml

defaultMimeTypeTable                    :: MimeTypeTable
defaultMimeTypeTable                    = M.fromList mimeTypeDefaults

extensionToMimeType                     :: String -> MimeTypeTable -> String
extensionToMimeType e                   = fromMaybe "" . lookupMime
    where
    lookupMime t                        = M.lookup e t                  -- try exact match
                                          `mplus`
                                          M.lookup (map toLower e) t    -- else try lowercase match
                                          `mplus`
                                          M.lookup (map toUpper e) t    -- else try uppercase match

-- ------------------------------------------------------------

readMimeTypeTable                       :: FilePath -> IO MimeTypeTable
readMimeTypeTable inp                   = do
                                          cb <- B.readFile inp
                                          return . M.fromList . parseMimeTypeTable . C.unpack $ cb

parseMimeTypeTable                      :: String -> [(String, String)]
parseMimeTypeTable                      = concat
                                          . map buildPairs
                                          . map words
                                          . filter (not . ("#" `isPrefixOf`))
                                          . filter (not . all (isSpace))
                                          . lines
    where
    buildPairs                          :: [String] -> [(String, String)]
    buildPairs  []                      = []
    buildPairs  (mt:exts)               = map (\ x -> (x, mt)) $ exts

-- ------------------------------------------------------------