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

{- |
   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 :: String
application_xhtml                       = String
"application/xhtml+xml"
application_xml :: String
application_xml                         = String
"application/xml"
application_xml_external_parsed_entity :: String
application_xml_external_parsed_entity  = String
"application/xml-external-parsed-entity"
application_xml_dtd :: String
application_xml_dtd                     = String
"application/xml-dtd"

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

isTextMimeType                          :: String -> Bool
isTextMimeType :: String -> Bool
isTextMimeType                          = (String
"text/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)

isHtmlMimeType                          :: String -> Bool
isHtmlMimeType :: String -> Bool
isHtmlMimeType String
t                        = String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
text_html

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

defaultMimeTypeTable                    :: MimeTypeTable
defaultMimeTypeTable :: MimeTypeTable
defaultMimeTypeTable                    = [(String, String)] -> MimeTypeTable
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, String)]
mimeTypeDefaults

extensionToMimeType                     :: String -> MimeTypeTable -> String
extensionToMimeType :: String -> MimeTypeTable -> String
extensionToMimeType String
e                   = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> (MimeTypeTable -> Maybe String) -> MimeTypeTable -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MimeTypeTable -> Maybe String
forall a. Map String a -> Maybe a
lookupMime
    where
    lookupMime :: Map String a -> Maybe a
lookupMime Map String a
t                        = String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
e Map String a
t                  -- try exact match
                                          Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                                          String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
e) Map String a
t    -- else try lowercase match
                                          Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                                          String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
e) Map String a
t    -- else try uppercase match

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

readMimeTypeTable                       :: FilePath -> IO MimeTypeTable
readMimeTypeTable :: String -> IO MimeTypeTable
readMimeTypeTable String
inp                   = do
                                          ByteString
cb <- String -> IO ByteString
B.readFile String
inp
                                          MimeTypeTable -> IO MimeTypeTable
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeTypeTable -> IO MimeTypeTable)
-> (ByteString -> MimeTypeTable) -> ByteString -> IO MimeTypeTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> MimeTypeTable
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, String)] -> MimeTypeTable)
-> (ByteString -> [(String, String)])
-> ByteString
-> MimeTypeTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)]
parseMimeTypeTable (String -> [(String, String)])
-> (ByteString -> String) -> ByteString -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C.unpack (ByteString -> IO MimeTypeTable) -> ByteString -> IO MimeTypeTable
forall a b. (a -> b) -> a -> b
$ ByteString
cb

parseMimeTypeTable                      :: String -> [(String, String)]
parseMimeTypeTable :: String -> [(String, String)]
parseMimeTypeTable                      = [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                          ([[(String, String)]] -> [(String, String)])
-> (String -> [[(String, String)]]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [(String, String)])
-> [[String]] -> [[(String, String)]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [(String, String)]
buildPairs
                                          ([[String]] -> [[(String, String)]])
-> (String -> [[String]]) -> String -> [[(String, String)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words
                                          ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                                          ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Bool
isSpace))
                                          ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    where
    buildPairs                          :: [String] -> [(String, String)]
    buildPairs :: [String] -> [(String, String)]
buildPairs  []                      = []
    buildPairs  (String
mt:[String]
exts)               = (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\ String
x -> (String
x, String
mt)) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ [String]
exts

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