3 , GeneralizedNewtypeDeriving
8 -- |Guessing MIME Types by file extensions. It's not always accurate
9 -- but simple and fast.
11 -- In general you don't have to use this module directly.
12 module Network.HTTP.Lucu.MIMEType.Guess
19 import Control.Applicative
20 import Data.Attoparsec.Char8 as P
21 import Data.Attoparsec.Lazy as LP
22 import qualified Data.ByteString.Lazy.Char8 as Lazy
23 import qualified Data.Map as M
28 import Data.Monoid.Unicode
29 import Data.Text (Text)
30 import qualified Data.Text as T
31 import Data.Text.Encoding
32 import Language.Haskell.TH.Syntax
33 import Language.Haskell.TH.Quote
34 import Network.HTTP.Lucu.MIMEType
35 import Network.HTTP.Lucu.OrphanInstances ()
36 import Network.HTTP.Lucu.Parser
37 import Prelude.Unicode
38 import System.FilePath
40 -- |A 'Map' from file extensions to 'MIMEType's.
42 = ExtMap (Map Text MIMEType)
43 deriving (Eq, Show, Read, Monoid, Typeable)
45 instance Lift ExtMap where
46 lift (ExtMap m) = [| ExtMap $(lift m) |]
48 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
53 -- # MIME Type Extensions
54 -- application/xhtml+xml xhtml
55 -- image/jpeg jpeg jpg
63 extMap = QuasiQuoter {
64 quoteExp = lift ∘ parseExtMap ∘ Lazy.pack
65 , quotePat = const unsupported
66 , quoteType = const unsupported
67 , quoteDec = const unsupported
70 unsupported ∷ Monad m ⇒ m α
71 unsupported = fail "Unsupported usage of extMap quasi-quoter."
73 -- |Parse Apache @mime.types@.
74 parseExtMap ∷ Lazy.ByteString → ExtMap
76 = case LP.parse pairs src of
78 → error $ "Unparsable extension map: "
79 ⧺ intercalate ", " eCtx
85 Left e → error ("Duplicate extension: " ⧺ show e)
87 pairs ∷ Parser [(MIMEType, [Text])]
88 pairs = do skipMany linebreak
89 xs ← sepBy pair (skipMany1 linebreak)
96 pair ∷ Parser (MIMEType, [Text])
100 exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
106 ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum)
110 linebreak ∷ Parser ()
114 try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
119 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
120 compile = go (∅) ∘ concat ∘ map tr
122 tr ∷ (v, [k]) → [(k, v)]
123 tr (v, ks) = [(k, v) | k ← ks]
125 go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
128 = case M.insertLookupWithKey' f k v m of
129 (Nothing, m') → go m' xs
130 (Just v0, _ ) → Left (k, v0, v)
135 -- |Guess the MIME Type of a file.
136 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
137 guessTypeByFileName (ExtMap m) fpath
138 = case takeExtension fpath of
140 (_:ext) → M.lookup (T.pack ext) m