{- 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  : stable
   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 ( foldM )
import System.IO
    ( Handle, hClose, openFile, IOMode(ReadMode) )
import System.IO.Error ()
import System.IO.Utils ( hGetLines )
import System.Path ( splitExt )
import Data.Map.Utils ( flippedLookupM )
import Data.Char ( toLower )

----------------------------------------------------------------------
-- 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".
     MIMETypeData -> Map String String
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".
     MIMETypeData -> Map String String
encodingsMap :: Map.Map String String,
     -- | A mapping used to map extensions to MIME types.
     MIMETypeData -> Map String String
typesMap :: Map.Map String String,
     -- | A mapping used to augment the 'typesMap' when non-strict
     -- lookups are used.
     MIMETypeData -> Map String String
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 :: MIMETypeData -> Bool -> String -> IO MIMETypeData
readMIMETypes MIMETypeData
mtd Bool
strict String
fn = do
                         Handle
h <- String -> IOMode -> IO Handle
openFile String
fn IOMode
ReadMode
                         MIMETypeData -> Bool -> Handle -> IO MIMETypeData
hReadMIMETypes MIMETypeData
mtd Bool
strict Handle
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 :: MIMETypeData -> Bool -> Handle -> IO MIMETypeData
hReadMIMETypes MIMETypeData
mtd Bool
strict Handle
h = (MIMETypeData -> String -> MIMETypeData)
-> MIMETypeData -> [String] -> MIMETypeData
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MIMETypeData -> String -> MIMETypeData
parseline MIMETypeData
mtd ([String] -> MIMETypeData) -> IO [String] -> IO MIMETypeData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [String]
forall a. HVIO a => a -> IO [String]
hGetLines Handle
h
    where
        parseline :: MIMETypeData -> String -> MIMETypeData
        parseline :: MIMETypeData -> String -> MIMETypeData
parseline MIMETypeData
obj String
line =
            let l1 :: [String]
l1 = String -> [String]
words String
line
                procwords :: [String] -> [String]
procwords [] = []
                procwords ((Char
'#':String
_) :[String]
_) = []
                procwords (String
x:[String]
xs) = String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
procwords [String]
xs
                l2 :: [String]
l2 = [String] -> [String]
procwords [String]
l1
                in
                if ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l2) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then
                   let thetype :: String
thetype = [String] -> String
forall a. [a] -> a
head [String]
l2
                       suffixlist :: [String]
suffixlist = [String] -> [String]
forall a. [a] -> [a]
tail [String]
l2
                       in
                       (MIMETypeData -> String -> MIMETypeData)
-> MIMETypeData -> [String] -> MIMETypeData
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\MIMETypeData
o String
suff -> MIMETypeData -> Bool -> String -> String -> MIMETypeData
addType MIMETypeData
o Bool
strict String
thetype (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
suff)) MIMETypeData
obj [String]
suffixlist
                else MIMETypeData
obj

{- | 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 :: MIMETypeData -> Bool -> String -> MIMEResults
guessType MIMETypeData
mtd Bool
strict String
fn =
    let mapext :: (String, String) -> (String, String)
mapext (String
base, String
ex) =
            case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ex (MIMETypeData -> Map String String
suffixMap MIMETypeData
mtd) of
                Maybe String
Nothing -> (String
base, String
ex)
                Just String
x -> (String, String) -> (String, String)
mapext (String -> (String, String)
splitExt (String
base String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x))
        checkencodings :: (String, String) -> (String, String, Maybe String)
checkencodings (String
base, String
ex) =
            case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ex (MIMETypeData -> Map String String
encodingsMap MIMETypeData
mtd) of
                 Maybe String
Nothing -> (String
base, String
ex, Maybe String
forall a. Maybe a
Nothing)
                 Just String
x -> ((String, String) -> String
forall a b. (a, b) -> a
fst (String -> (String, String)
splitExt String
base),
                            (String, String) -> String
forall a b. (a, b) -> b
snd (String -> (String, String)
splitExt String
base),
                            String -> Maybe String
forall a. a -> Maybe a
Just String
x)
        (String
_, String
ext, Maybe String
enc) = (String, String) -> (String, String, Maybe String)
checkencodings ((String, String) -> (String, String, Maybe String))
-> ((String, String) -> (String, String))
-> (String, String)
-> (String, String, Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> (String, String)
mapext ((String, String) -> (String, String, Maybe String))
-> (String, String) -> (String, String, Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitExt String
fn
        typemap :: Map String String
typemap = MIMETypeData -> Bool -> Map String String
getStrict MIMETypeData
mtd Bool
strict
        in
        case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ext Map String String
typemap of
             Maybe String
Nothing -> (String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
ext) Map String String
typemap, Maybe String
enc)
             Just String
x -> (String -> Maybe String
forall a. a -> Maybe a
Just String
x, Maybe String
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 :: MIMETypeData -> Bool -> String -> Maybe String
guessExtension MIMETypeData
mtd Bool
strict String
fn =
    case MIMETypeData -> Bool -> String -> [String]
guessAllExtensions MIMETypeData
mtd Bool
strict String
fn of
                                          [] -> Maybe String
forall a. Maybe a
Nothing
                                          (String
x:[String]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
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 :: MIMETypeData -> Bool -> String -> [String]
guessAllExtensions MIMETypeData
mtd Bool
strict String
fn =
    let mimetype :: String
mimetype = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fn
        themap :: Map String String
themap = MIMETypeData -> Bool -> Map String String
getStrict MIMETypeData
mtd Bool
strict
        in
        String -> Map String String -> [String]
forall val key. (Ord val, Ord key) => val -> Map key val -> [key]
flippedLookupM String
mimetype Map String String
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 :: MIMETypeData -> Bool -> String -> String -> MIMETypeData
addType MIMETypeData
mtd Bool
strict String
thetype String
theext =
    MIMETypeData
-> Bool -> (Map String String -> Map String String) -> MIMETypeData
setStrict MIMETypeData
mtd Bool
strict (\Map String String
m -> String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
theext String
thetype Map String String
m)

{- | Default MIME type data to use -}
defaultmtd :: MIMETypeData
defaultmtd :: MIMETypeData
defaultmtd =
    MIMETypeData :: Map String String
-> Map String String
-> Map String String
-> Map String String
-> MIMETypeData
MIMETypeData {suffixMap :: Map String String
suffixMap = Map String String
default_suffix_map,
                  encodingsMap :: Map String String
encodingsMap = Map String String
default_encodings_map,
                  typesMap :: Map String String
typesMap = Map String String
default_types_map,
                  commonTypesMap :: Map String String
commonTypesMap = Map String String
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 :: MIMETypeData -> IO MIMETypeData
readSystemMIMETypes MIMETypeData
mtd =
    let tryread :: MIMETypeData -> String -> IO MIMETypeData
        tryread :: MIMETypeData -> String -> IO MIMETypeData
tryread MIMETypeData
inputobj String
filename =
            do
            Either IOException Handle
fn <- IO Handle -> IO (Either IOException Handle)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (String -> IOMode -> IO Handle
openFile String
filename IOMode
ReadMode)
            case Either IOException Handle
fn of
                    Left (IOException
_ :: Control.Exception.IOException) -> MIMETypeData -> IO MIMETypeData
forall (m :: * -> *) a. Monad m => a -> m a
return MIMETypeData
inputobj
                    Right Handle
h -> do
                               MIMETypeData
x <- MIMETypeData -> Bool -> Handle -> IO MIMETypeData
hReadMIMETypes MIMETypeData
inputobj Bool
True Handle
h
                               Handle -> IO ()
hClose Handle
h
                               MIMETypeData -> IO MIMETypeData
forall (m :: * -> *) a. Monad m => a -> m a
return MIMETypeData
x
        in
        do
          (MIMETypeData -> String -> IO MIMETypeData)
-> MIMETypeData -> [String] -> IO MIMETypeData
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MIMETypeData -> String -> IO MIMETypeData
tryread MIMETypeData
mtd [String]
defaultfilelocations

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

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

----------------------------------------------------------------------
-- Default data structures
----------------------------------------------------------------------
defaultfilelocations :: [String]
defaultfilelocations :: [String]
defaultfilelocations =
    [
     String
"/etc/mime.types",
     String
"/usr/local/etc/httpd/conf/mime.types",
     String
"/usr/local/lib/netscape/mime.types",
     String
"/usr/local/etc/httpd/conf/mime.types",     -- Apache 1.2
     String
"/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 String String
default_encodings_map = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                                      (String
".Z", String
"compress"),
                                      (String
".gz", String
"gzip"),
                                      (String
".bz2", String
"bzip2")
                                     ]

default_suffix_map :: Map String String
default_suffix_map = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                                   (String
".tgz", String
".tar.gz"),
                                   (String
".tz", String
".tar.gz"),
                                   (String
".taz", String
".tar.gz")
                                  ]

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

default_common_types :: Map String String
default_common_types = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                                     (String
".jpg", String
"image/jpg"),
                                     (String
".mid", String
"audio/midi"),
                                     (String
".midi", String
"audio/midi"),
                                     (String
".pct", String
"image/pict"),
                                     (String
".pic", String
"image/pict"),
                                     (String
".pict", String
"image/pict"),
                                     (String
".rtf", String
"application/rtf"),
                                     (String
".xul", String
"text/xul")
                                    ]