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
21 import qualified 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 <$> 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 ∘ (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