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.Parser
36 import Network.HTTP.Lucu.Utils
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
47 = [| ExtMap $(liftMap liftText lift m) |]
49 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
54 -- # MIME Type Extensions
55 -- application/xhtml+xml xhtml
56 -- image/jpeg jpeg jpg
64 extMap = QuasiQuoter {
65 quoteExp = lift ∘ parseExtMap ∘ Lazy.pack
66 , quotePat = const unsupported
67 , quoteType = const unsupported
68 , quoteDec = const unsupported
71 unsupported ∷ Monad m ⇒ m α
72 unsupported = fail "Unsupported usage of extMap quasi-quoter."
74 -- |Parse Apache @mime.types@.
75 parseExtMap ∷ Lazy.ByteString → ExtMap
77 = case LP.parse pairs src of
79 → error $ "Unparsable extension map: "
80 ⧺ intercalate ", " eCtx
86 Left e → error ("Duplicate extension: " ⧺ show e)
88 pairs ∷ Parser [(MIMEType, [Text])]
89 pairs = do skipMany linebreak
90 xs ← sepBy pair (skipMany1 linebreak)
97 pair ∷ Parser (MIMEType, [Text])
101 exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
107 ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum)
111 linebreak ∷ Parser ()
115 try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
120 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
121 compile = go (∅) ∘ concat ∘ map tr
123 tr ∷ (v, [k]) → [(k, v)]
124 tr (v, ks) = [(k, v) | k ← ks]
126 go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
129 = case M.insertLookupWithKey' f k v m of
130 (Nothing, m') → go m' xs
131 (Just v0, _ ) → Left (k, v0, v)
136 -- |Guess the MIME Type of a file.
137 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
138 guessTypeByFileName (ExtMap m) fpath
139 = case takeExtension fpath of
141 (_:ext) → M.lookup (T.pack ext) m