{-# LANGUAGE Safe #-}

{- 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
   SPDX-License-Identifier: BSD-3-Clause

   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")
                                    ]