    {- arch-tag: MIME Types main file
    Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

    All rights reserved.

    For license and copyright information, see the file LICENSE
    -}

    {- |
       Module     : Data.MIME.Types
       Copyright  : Copyright (C) 2004-2011 John Goerzen
       License    : BSD3

       Maintainer : John Goerzen <jgoerzen@complete.org>
       Stability  : provisional
       Portability: portable

    Utilities for guessing MIME types of files.

    Written by John Goerzen, jgoerzen\@complete.org
    -}

    module Data.MIME.Types (-- * Creating Lookup Objects
                               defaultmtd,
                               readMIMETypes,
                               hReadMIMETypes,
                               readSystemMIMETypes,
                               -- * Basic Access
                               MIMEResults,
                               MIMETypeData(..),
                               guessType,
                               guessExtension,
                               guessAllExtensions
                              )
    where

    import qualified Data.Map as Map
    import qualified Control.Exception (try, IOException)
    import Control.Monad
    import System.IO
    import System.IO.Error
    import System.IO.Utils
    import System.Path
    import Data.Map.Utils
    import Data.Char

    ----------------------------------------------------------------------
    -- Basic type declarations
    ----------------------------------------------------------------------

    data MIMETypeData = MIMETypeData
        {
         -- | A mapping used to expand common suffixes into equivolent,
         -- better-parsed versions.  For instance, ".tgz" would expand
         -- into ".tar.gz".
         suffixMap :: Map.Map String String,
         -- | A mapping used to determine the encoding of a file.
         -- This is used, for instance, to map ".gz" to "gzip".
         encodingsMap :: Map.Map String String,
         -- | A mapping used to map extensions to MIME types.
         typesMap :: Map.Map String String,
         -- | A mapping used to augment the 'typesMap' when non-strict
         -- lookups are used.
         commonTypesMap :: Map.Map String String
        }

    {- | Return value from guessing a file's type.

    The first element of the tuple gives the MIME type.  It is Nothing if no
    suitable type could be found.

    The second element gives the encoding.  It is Nothing if there was no particular
    encoding for the file, or if no encoding could be found.
    -}
    type MIMEResults = (Maybe String,       -- The MIME type
                        Maybe String        -- Encoding
                       )

    {- | Read the given mime.types file and add it to an existing object.
    Returns new object. -}
    readMIMETypes :: MIMETypeData            -- ^ Data to work with
                  -> Bool                    -- ^ Whether to work on strict data
                  -> FilePath               -- ^ File to read
                  -> IO MIMETypeData           -- ^ New object
    readMIMETypes mtd strict fn = do
                             h <- openFile fn ReadMode
                             hReadMIMETypes mtd strict h

    {- | Load a mime.types file from an already-open handle. -}
    hReadMIMETypes :: MIMETypeData          -- ^ Data to work with
                      -> Bool               -- ^ Whether to work on strict data
                      -> Handle             -- ^ Handle to read from
                      -> IO MIMETypeData       -- ^ New object
    hReadMIMETypes mtd strict h =
        let parseline :: MIMETypeData -> String -> MIMETypeData
            parseline obj line =
                let l1 = words line
                    procwords [] = []
                    procwords (('#':_) :_) = []
                    procwords (x:xs) = x : procwords xs
                    l2 = procwords l1
                    in
                    if (length l2) >= 2 then
                       let thetype = head l2
                           suffixlist = tail l2
                           in
                           foldl (\o suff -> addType o strict thetype ('.' : suff)) obj suffixlist
                    else obj
            in
              do
                lines <- hGetLines h
                return (foldl parseline mtd lines)

    {- | Guess the type of a file given a filename or URL.  The file
       is not opened; only the name is considered. -}
    guessType :: MIMETypeData               -- ^ Source data for guessing
                 -> Bool                    -- ^ Whether to limit to strict data
                 -> String                  -- ^ File or URL name to consider
                 -> MIMEResults             -- ^ Result of guessing (see 'MIMEResults' for details on interpreting it)
    guessType mtd strict fn =
        let mapext (base, ex) =
                case Map.lookup ex (suffixMap mtd) of
                    Nothing -> (base, ex)
                    Just x -> mapext (splitExt (base ++ x))
            checkencodings (base, ex) =
                case Map.lookup ex (encodingsMap mtd) of
                     Nothing -> (base, ex, Nothing)
                     Just x -> (fst (splitExt base),
                                snd (splitExt base),
                                Just x)
            (_, ext, enc) = checkencodings . mapext $ splitExt fn
            typemap = getStrict mtd strict
            in
            case Map.lookup ext typemap of
                 Nothing -> (Map.lookup (map toLower ext) typemap, enc)
                 Just x -> (Just x, enc)

    {- | Guess the extension of a file based on its MIME type.
       The return value includes the leading dot.

       Returns Nothing if no extension could be found.

       In the event that multiple possible extensions are available,
       one of them will be picked and returned.  The logic to select one
       of these should be considered undefined. -}
    guessExtension :: MIMETypeData          -- ^ Source data for guessing
                      -> Bool               -- ^ Whether to limit to strict data
                      -> String             -- ^ MIME type to consider
                      -> Maybe String       -- ^ Result of guessing, or Nothing if no match possible
    guessExtension mtd strict fn =
        case guessAllExtensions mtd strict fn of
                                              [] -> Nothing
                                              (x:_) -> Just x

    {- | Similar to 'guessExtension', but returns a list of all possible matching
    extensions, or the empty list if there are no matches. -}
    guessAllExtensions :: MIMETypeData      -- ^ Source data for guessing
                          -> Bool           -- ^ Whether to limit to strict data
                          -> String         -- ^ MIME type to consider
                          -> [String]       -- ^ Result of guessing
    guessAllExtensions mtd strict fn =
        let mimetype = map toLower fn
            themap = getStrict mtd strict
            in
            flippedLookupM mimetype themap

    {- | Adds a new type to the data structures, replacing whatever data
       may exist about it already.  That is, it overrides existing information
       about the given extension, but the same type may occur more than once. -}
    addType :: MIMETypeData                 -- ^ Source data
               -> Bool                      -- ^ Whether to add to strict data set
               -> String                    -- ^ MIME type to add
               -> String                    -- ^ Extension to add
               -> MIMETypeData              -- ^ Result of addition
    addType mtd strict thetype theext =
        setStrict mtd strict (\m -> Map.insert theext thetype m)

    {- | Default MIME type data to use -}
    defaultmtd :: MIMETypeData
    defaultmtd =
        MIMETypeData {suffixMap = default_suffix_map,
                      encodingsMap = default_encodings_map,
                      typesMap = default_types_map,
                      commonTypesMap = default_common_types}

    {- | Read the system's default mime.types files, and add the data contained
    therein to the passed object, then return the new one. -}
    readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData
    readSystemMIMETypes mtd =
        let tryread :: MIMETypeData -> String -> IO MIMETypeData
            tryread inputobj filename =
                do
                fn <- Control.Exception.try (openFile filename ReadMode)
                case fn of
                        Left (_ :: Control.Exception.IOException) -> return inputobj
                        Right h -> do
                                   x <- hReadMIMETypes inputobj True h
                                   hClose h
                                   return x
            in
            do
              foldM tryread mtd defaultfilelocations

    ----------------------------------------------------------------------
    -- Internal utilities
    ----------------------------------------------------------------------
    getStrict :: MIMETypeData -> Bool -> Map.Map String String
    getStrict mtd True = typesMap mtd
    getStrict mtd False = Map.union (typesMap mtd) (commonTypesMap mtd)

    setStrict :: MIMETypeData -> Bool -> (Map.Map String String -> Map.Map String String) -> MIMETypeData
    setStrict mtd True func = mtd{typesMap = func (typesMap mtd)}
    setStrict mtd False func = mtd{commonTypesMap = func (commonTypesMap mtd)}

    ----------------------------------------------------------------------
    -- Default data structures
    ----------------------------------------------------------------------
    defaultfilelocations :: [String]
    defaultfilelocations =
        [
         "/etc/mime.types",
         "/usr/local/etc/httpd/conf/mime.types",
         "/usr/local/lib/netscape/mime.types",
         "/usr/local/etc/httpd/conf/mime.types",     -- Apache 1.2
         "/usr/local/etc/mime.types"                -- Apache 1.3
        ]

    default_encodings_map, default_suffix_map, default_types_map, default_common_types :: Map.Map String String
    default_encodings_map = Map.fromList [
                                          (".Z", "compress"),
                                          (".gz", "gzip"),
                                          (".bz2", "bzip2")
                                         ]

    default_suffix_map = Map.fromList [
                                       (".tgz", ".tar.gz"),
                                       (".tz", ".tar.gz"),
                                       (".taz", ".tar.gz")
                                      ]

    default_types_map = Map.fromList [
                                      (".a", "application/octet-stream"),
                                      (".ai", "application/postscript"),
                                      (".aif", "audio/x-aiff"),
                                      (".aifc", "audio/x-aiff"),
                                      (".aiff", "audio/x-aiff"),
                                      (".au", "audio/basic"),
                                      (".avi", "video/x-msvideo"),
                                      (".bat", "text/plain"),
                                      (".bcpio", "application/x-bcpio"),
                                      (".bin", "application/octet-stream"),
                                      (".bmp", "image/x-ms-bmp"),
                                      (".c", "text/plain"),
                                      (".cdf", "application/x-netcdf"),
                                      (".cpio", "application/x-cpio"),
                                      (".csh", "application/x-csh"),
                                      (".css", "text/css"),
                                      (".dll", "application/octet-stream"),
                                      (".doc", "application/msword"),
                                      (".dot", "application/msword"),
                                      (".dvi", "application/x-dvi"),
                                      (".eml", "message/rfc822"),
                                      (".eps", "application/postscript"),
                                      (".etx", "text/x-setext"),
                                      (".exe", "application/octet-stream"),
                                      (".gif", "image/gif"),
                                      (".gtar", "application/x-gtar"),
                                      (".h", "text/plain"),
                                      (".hdf", "application/x-hdf"),
                                      (".htm", "text/html"),
                                      (".html", "text/html"),
                                      (".ief", "image/ief"),
                                      (".jpe", "image/jpeg"),
                                      (".jpeg", "image/jpeg"),
                                      (".jpg", "image/jpeg"),
                                      (".js", "application/x-javascript"),
                                      (".ksh", "text/plain"),
                                      (".latex", "application/x-latex"),
                                      (".m1v", "video/mpeg"),
                                      (".man", "application/x-troff-man"),
                                      (".me", "application/x-troff-me"),
                                      (".mht", "message/rfc822"),
                                      (".mhtml", "message/rfc822"),
                                      (".mif", "application/x-mif"),
                                      (".mov", "video/quicktime"),
                                      (".movie", "video/x-sgi-movie"),
                                      (".mp2", "audio/mpeg"),
                                      (".mp3", "audio/mpeg"),
                                      (".mpa", "video/mpeg"),
                                      (".mpe", "video/mpeg"),
                                      (".mpeg", "video/mpeg"),
                                      (".mpg", "video/mpeg"),
                                      (".ms", "application/x-troff-ms"),
                                      (".nc", "application/x-netcdf"),
                                      (".nws", "message/rfc822"),
                                      (".o", "application/octet-stream"),
                                      (".obj", "application/octet-stream"),
                                      (".oda", "application/oda"),
                                      (".p12", "application/x-pkcs12"),
                                      (".p7c", "application/pkcs7-mime"),
                                      (".pbm", "image/x-portable-bitmap"),
                                      (".pdf", "application/pdf"),
                                      (".pfx", "application/x-pkcs12"),
                                      (".pgm", "image/x-portable-graymap"),
                                      (".pl", "text/plain"),
                                      (".png", "image/png"),
                                      (".pnm", "image/x-portable-anymap"),
                                      (".pot", "application/vnd.ms-powerpoint"),
                                      (".ppa", "application/vnd.ms-powerpoint"),
                                      (".ppm", "image/x-portable-pixmap"),
                                      (".pps", "application/vnd.ms-powerpoint"),
                                      (".ppt", "application/vnd.ms-powerpoint"),
                                      (".ps", "application/postscript"),
                                      (".pwz", "application/vnd.ms-powerpoint"),
                                      (".py", "text/x-python"),
                                      (".pyc", "application/x-python-code"),
                                      (".pyo", "application/x-python-code"),
                                      (".qt", "video/quicktime"),
                                      (".ra", "audio/x-pn-realaudio"),
                                      (".ram", "application/x-pn-realaudio"),
                                      (".ras", "image/x-cmu-raster"),
                                      (".rdf", "application/xml"),
                                      (".rgb", "image/x-rgb"),
                                      (".roff", "application/x-troff"),
                                      (".rtx", "text/richtext"),
                                      (".sgm", "text/x-sgml"),
                                      (".sgml", "text/x-sgml"),
                                      (".sh", "application/x-sh"),
                                      (".shar", "application/x-shar"),
                                      (".snd", "audio/basic"),
                                      (".so", "application/octet-stream"),
                                      (".src", "application/x-wais-source"),
                                      (".sv4cpio", "application/x-sv4cpio"),
                                      (".sv4crc", "application/x-sv4crc"),
                                      (".swf", "application/x-shockwave-flash"),
                                      (".t", "application/x-troff"),
                                      (".tar", "application/x-tar"),
                                      (".tcl", "application/x-tcl"),
                                      (".tex", "application/x-tex"),
                                      (".texi", "application/x-texinfo"),
                                      (".texinfo", "application/x-texinfo"),
                                      (".tif", "image/tiff"),
                                      (".tiff", "image/tiff"),
                                      (".tr", "application/x-troff"),
                                      (".tsv", "text/tab-separated-values"),
                                      (".txt", "text/plain"),
                                      (".ustar", "application/x-ustar"),
                                      (".vcf", "text/x-vcard"),
                                      (".wav", "audio/x-wav"),
                                      (".wiz", "application/msword"),
                                      (".xbm", "image/x-xbitmap"),
                                      (".xlb", "application/vnd.ms-excel"),
                                      (".xls", "application/vnd.ms-excel"),
                                      (".xml", "text/xml"),
                                      (".xpm", "image/x-xpixmap"),
                                      (".xsl", "application/xml"),
                                      (".xwd", "image/x-xwindowdump"),
                                      (".zip", "application/zip")
                                     ]

    default_common_types = Map.fromList [
                                         (".jpg", "image/jpg"),
                                         (".mid", "audio/midi"),
                                         (".midi", "audio/midi"),
                                         (".pct", "image/pict"),
                                         (".pic", "image/pict"),
                                         (".pict", "image/pict"),
                                         (".rtf", "application/rtf"),
                                         (".xul", "text/xul")
                                        ]