{-# LANGUAGE Safe #-}
module Data.MIME.Types (
defaultmtd,
readMIMETypes,
hReadMIMETypes,
readSystemMIMETypes,
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
data MIMETypeData = MIMETypeData
{
MIMETypeData -> Map String String
suffixMap :: Map.Map String String,
MIMETypeData -> Map String String
encodingsMap :: Map.Map String String,
MIMETypeData -> Map String String
typesMap :: Map.Map String String,
MIMETypeData -> Map String String
commonTypesMap :: Map.Map String String
}
type MIMEResults = (Maybe String,
Maybe String
)
readMIMETypes :: MIMETypeData
-> Bool
-> FilePath
-> IO MIMETypeData
readMIMETypes :: MIMETypeData -> Bool -> String -> IO MIMETypeData
readMIMETypes mtd :: MIMETypeData
mtd strict :: Bool
strict fn :: 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
hReadMIMETypes :: MIMETypeData
-> Bool
-> Handle
-> IO MIMETypeData
hReadMIMETypes :: MIMETypeData -> Bool -> Handle -> IO MIMETypeData
hReadMIMETypes mtd :: MIMETypeData
mtd strict :: Bool
strict h :: Handle
h =
let parseline :: MIMETypeData -> String -> MIMETypeData
parseline :: MIMETypeData -> String -> MIMETypeData
parseline obj :: MIMETypeData
obj line :: String
line =
let l1 :: [String]
l1 = String -> [String]
words String
line
procwords :: [String] -> [String]
procwords [] = []
procwords (('#':_) :_) = []
procwords (x :: String
x:xs :: [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
>= 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 (\o :: MIMETypeData
o suff :: String
suff -> MIMETypeData -> Bool -> String -> String -> MIMETypeData
addType MIMETypeData
o Bool
strict String
thetype ('.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
suff)) MIMETypeData
obj [String]
suffixlist
else MIMETypeData
obj
in
do
[String]
lines <- Handle -> IO [String]
forall a. HVIO a => a -> IO [String]
hGetLines Handle
h
MIMETypeData -> IO MIMETypeData
forall (m :: * -> *) a. Monad m => a -> m a
return ((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]
lines)
guessType :: MIMETypeData
-> Bool
-> String
-> MIMEResults
guessType :: MIMETypeData -> Bool -> String -> MIMEResults
guessType mtd :: MIMETypeData
mtd strict :: Bool
strict fn :: String
fn =
let mapext :: (String, String) -> (String, String)
mapext (base :: String
base, ex :: 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
Nothing -> (String
base, String
ex)
Just x :: 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 (base :: String
base, ex :: 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
Nothing -> (String
base, String
ex, Maybe String
forall a. Maybe a
Nothing)
Just x :: 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)
(_, ext :: String
ext, enc :: 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
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 x :: String
x -> (String -> Maybe String
forall a. a -> Maybe a
Just String
x, Maybe String
enc)
guessExtension :: MIMETypeData
-> Bool
-> String
-> Maybe String
guessExtension :: MIMETypeData -> Bool -> String -> Maybe String
guessExtension mtd :: MIMETypeData
mtd strict :: Bool
strict fn :: String
fn =
case MIMETypeData -> Bool -> String -> [String]
guessAllExtensions MIMETypeData
mtd Bool
strict String
fn of
[] -> Maybe String
forall a. Maybe a
Nothing
(x :: String
x:_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
guessAllExtensions :: MIMETypeData
-> Bool
-> String
-> [String]
guessAllExtensions :: MIMETypeData -> Bool -> String -> [String]
guessAllExtensions mtd :: MIMETypeData
mtd strict :: Bool
strict fn :: 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
addType :: MIMETypeData
-> Bool
-> String
-> String
-> MIMETypeData
addType :: MIMETypeData -> Bool -> String -> String -> MIMETypeData
addType mtd :: MIMETypeData
mtd strict :: Bool
strict thetype :: String
thetype theext :: String
theext =
MIMETypeData
-> Bool -> (Map String String -> Map String String) -> MIMETypeData
setStrict MIMETypeData
mtd Bool
strict (\m :: 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)
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}
readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData
readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData
readSystemMIMETypes mtd :: MIMETypeData
mtd =
let tryread :: MIMETypeData -> String -> IO MIMETypeData
tryread :: MIMETypeData -> String -> IO MIMETypeData
tryread inputobj :: MIMETypeData
inputobj filename :: 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 h :: 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
getStrict :: MIMETypeData -> Bool -> Map.Map String String
getStrict :: MIMETypeData -> Bool -> Map String String
getStrict mtd :: MIMETypeData
mtd True = MIMETypeData -> Map String String
typesMap MIMETypeData
mtd
getStrict mtd :: MIMETypeData
mtd 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 mtd :: MIMETypeData
mtd True func :: 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 mtd :: MIMETypeData
mtd False func :: 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)}
defaultfilelocations :: [String]
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",
"/usr/local/etc/mime.types"
]
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 [
(".Z", "compress"),
(".gz", "gzip"),
(".bz2", "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 [
(".tgz", ".tar.gz"),
(".tz", ".tar.gz"),
(".taz", ".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 [
(".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 String String
default_common_types = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
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")
]