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
21 import Control.Monad.Unicode
22 import Data.Ascii (Ascii)
23 import qualified Data.Ascii as A
24 import Data.Attoparsec.Char8 as P
25 import qualified Data.Map as M
30 import Data.Monoid.Unicode
31 import Data.Text (Text)
32 import qualified Data.Text as T
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.Parser
38 import Network.HTTP.Lucu.Utils
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
49 = [| ExtMap $(liftMap liftText lift m) |]
51 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
56 -- # MIME Type Extensions
57 -- application/xhtml+xml xhtml
58 -- image/jpeg jpeg jpg
66 extMap = QuasiQuoter {
67 quoteExp = (lift ∘ parseExtMap =≪) ∘ toAscii
68 , quotePat = const unsupported
69 , quoteType = const unsupported
70 , quoteDec = const unsupported
73 toAscii ∷ Monad m ⇒ String → m Ascii
74 toAscii (A.fromChars → Just a) = return a
75 toAscii _ = fail "Malformed extension map"
77 unsupported ∷ Monad m ⇒ m α
78 unsupported = fail "Unsupported usage of extMap quasi-quoter."
80 -- |Parse Apache @mime.types@.
81 parseExtMap ∷ Ascii → ExtMap
83 = case parseOnly (finishOff extMapP) $ A.toByteString src of
84 Right xs → case compile xs of
86 Left e → error ("Duplicate extension: " ⧺ show e)
87 Left err → error ("Unparsable extension map: " ⧺ err)
89 extMapP ∷ Parser [(MIMEType, [Text])]
90 extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
93 isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
95 comment ∷ Parser (Maybe (MIMEType, [Text]))
96 comment = do skipWhile isSpc
101 validLine ∷ Parser (Maybe (MIMEType, [Text]))
102 validLine = do skipWhile isSpc
105 exts ← sepBy extP (skipWhile isSpc)
106 return $ Just (mime, exts)
109 extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
111 emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
112 emptyLine = do skipWhile isSpc
116 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
117 compile = go (∅) ∘ concat ∘ map tr
119 tr ∷ (v, [k]) → [(k, v)]
120 tr (v, ks) = [(k, v) | k ← ks]
122 go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
125 = case M.insertLookupWithKey' f k v m of
126 (Nothing, m') → go m' xs
127 (Just v0, _ ) → Left (k, v0, v)
132 -- |Guess the MIME Type of a file.
133 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
134 guessTypeByFileName (ExtMap m) fpath
135 = case takeExtension fpath of
137 (_:ext) → M.lookup (T.pack ext) m