3 , GeneralizedNewtypeDeriving
4 , MultiParamTypeClasses
9 -- |Guessing MIME Types by file extensions. It's not always accurate
10 -- but simple and fast.
12 -- In general you don't have to use this module directly.
13 module Network.HTTP.Lucu.MIMEType.Guess
19 import Control.Applicative
20 import Data.Attoparsec.Char8
21 import qualified Data.Attoparsec.Lazy as LP
22 import Data.Attoparsec.Parsable
23 import qualified Data.ByteString.Lazy.Char8 as Lazy
24 import Data.Convertible.Base
25 import Data.Convertible.Instances.Text ()
26 import qualified Data.Map as M
31 import Data.Monoid.Unicode
32 import Data.Text (Text)
33 import Data.Text.Encoding
34 import Language.Haskell.TH.Syntax
35 import Language.Haskell.TH.Quote
36 import Network.HTTP.Lucu.MIMEType
37 import Network.HTTP.Lucu.OrphanInstances ()
38 import Network.HTTP.Lucu.Parser
39 import Prelude.Unicode
40 import System.FilePath
42 -- |A 'Map' from file extensions to 'MIMEType's.
44 = ExtMap (Map Text MIMEType)
45 deriving (Eq, Show, Read, Monoid, Typeable)
47 instance Lift ExtMap where
48 lift (ExtMap m) = [| ExtMap $(lift m) |]
50 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
55 -- # MIME Type Extensions
56 -- application/xhtml+xml xhtml
57 -- image/jpeg jpeg jpg
65 extMap = QuasiQuoter {
66 quoteExp = lift ∘ parseExtMap ∘ Lazy.pack
67 , quotePat = const unsupported
68 , quoteType = const unsupported
69 , quoteDec = const unsupported
72 parseExtMap ∷ Lazy.ByteString → ExtMap
73 parseExtMap = convertUnsafe
75 unsupported ∷ Monad m ⇒ m α
76 unsupported = fail "Unsupported usage of extMap quasi-quoter."
78 instance ConvertAttempt Lazy.ByteString ExtMap where
80 = case LP.parse pairs src of
82 → fail $ "Unparsable extension map: "
83 ⊕ intercalate ", " eCtx
88 Right m → return $ ExtMap m
89 Left e → fail $ "Duplicate extension: " ⊕ show e
91 pairs ∷ Parser [(MIMEType, [Text])]
92 pairs = do skipMany linebreak
93 xs ← sepBy pair (skipMany1 linebreak)
100 pair ∷ Parser (MIMEType, [Text])
104 exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
110 ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
114 linebreak ∷ Parser ()
118 try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
123 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
124 compile = go (∅) ∘ concat ∘ (tr <$>)
126 tr ∷ (v, [k]) → [(k, v)]
127 tr (v, ks) = [(k, v) | k ← ks]
129 go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
132 = case M.insertLookupWithKey' f k v m of
133 (Nothing, m') → go m' xs
134 (Just v0, _ ) → Left (k, v0, v)
139 -- |Guess the MIME Type of a file.
140 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
141 guessTypeByFileName (ExtMap m) fpath
142 = case takeExtension fpath of
144 (_:ext) → M.lookup (cs ext) m