4 -- |Guessing MIME Types by file extensions. It's not always accurate
5 -- but simple and fast.
7 -- In general you don't have to use this module directly.
8 module Network.HTTP.Lucu.MIMEType.Guess
16 import Control.Applicative
18 import qualified Data.Ascii as A
19 import Data.Attoparsec.Char8 as P
20 import qualified Data.Attoparsec.Lazy as LP
21 import qualified Data.ByteString.Lazy.Char8 as B
22 import qualified Data.Map as M
25 import Data.Monoid.Unicode
26 import Data.Text (Text)
27 import qualified Data.Text as T
28 import Data.Text.Encoding
29 import Language.Haskell.Exts.Build
30 import Language.Haskell.Exts.Extension
31 import Language.Haskell.Exts.Pretty
32 import Language.Haskell.Exts.Syntax
33 import Network.HTTP.Lucu.MIMEType
34 import Network.HTTP.Lucu.Parser
35 import Prelude.Unicode
36 import System.FilePath
38 -- |A 'Map' from file extensions to 'MIMEType's.
39 type ExtMap = Map Text MIMEType
41 -- |Guess the MIME Type of a file.
42 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
43 guessTypeByFileName em fpath
44 = case takeExtension fpath of
46 (_:ext) → M.lookup (T.pack ext) em
48 -- |Read an Apache mime.types and parse it.
49 parseExtMapFile ∷ FilePath → IO ExtMap
51 = do file ← B.readFile fpath
52 case LP.parse (finishOff extMap) file of
56 Left e → fail (concat [ "Duplicate extension \""
62 → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
64 extMap ∷ Parser [ (MIMEType, [Text]) ]
65 extMap = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
68 isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
70 comment ∷ Parser (Maybe (MIMEType, [Text]))
71 comment = do skipWhile isSpc
76 validLine ∷ Parser (Maybe (MIMEType, [Text]))
77 validLine = do skipWhile isSpc
80 exts ← sepBy extP (skipWhile isSpc)
81 return $ Just (mime, exts)
84 extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
86 emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
87 emptyLine = do skipWhile isSpc
91 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
92 compile = go (∅) ∘ concat ∘ map tr
94 tr ∷ (v, [k]) → [(k, v)]
95 tr (v, ks) = [(k, v) | k ← ks]
97 go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
100 = case M.insertLookupWithKey' f k v m of
101 (Nothing, m') → go m' xs
102 (Just v0, _ ) → Left (k, v0, v)
107 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
108 -- Haskell source code which contains the following things:
110 -- * A definition of module named @moduleName@.
112 -- * @variableName :: 'ExtMap'@ whose content is the serialised
115 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
116 -- surely generated using this function.
117 serializeExtMap ∷ ExtMap → String → String → String
118 serializeExtMap em moduleName variableName
119 = let hsModule = Module (⊥) (ModuleName moduleName) modPragma
120 Nothing (Just exports) imports decls
121 modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
122 exports = [ EVar (UnQual (name variableName)) ]
123 imports = [ ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType")
124 False False Nothing Nothing Nothing
125 , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType.Guess")
126 False False Nothing Nothing Nothing
127 , ImportDecl (⊥) (ModuleName "Data.Ascii")
128 False False Nothing Nothing (Just (False, []))
129 , ImportDecl (⊥) (ModuleName "Data.Map")
130 True False Nothing (Just (ModuleName "M")) Nothing
132 decls = [ TypeSig (⊥) [name variableName]
133 (TyCon (UnQual (name "ExtMap")))
134 , nameBind (⊥) (name variableName) extMapExp
135 , InlineSig (⊥) False AlwaysActive (UnQual (name variableName))
137 comment = concat [ "{- !!! WARNING !!!\n"
138 , " This file is automatically generated.\n"
139 , " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
141 extMapExp = qvar (ModuleName "M") (name "fromList") `app` listE records
143 comment ⧺ prettyPrint hsModule ⧺ "\n"
146 records = map record $ M.assocs em
148 record ∷ (Text, MIMEType) → Exp
150 = tuple [ strE (T.unpack ext)
151 , function "parseMIMEType" `app` strE (mimeToString mime)
154 mimeToString ∷ MIMEType → String
155 mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType