Network/HTTP/Lucu/MIMEType/Guess.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , GeneralizedNewtypeDeriving
   4   , TemplateHaskell
   5   , UnicodeSyntax
   6   , ViewPatterns
   7   #-}
   8 -- |Guessing MIME Types by file extensions. It's not always accurate
   9 -- but simple and fast.
  10 --
  11 -- In general you don't have to use this module directly.
  12 module Network.HTTP.Lucu.MIMEType.Guess
  13     ( ExtMap(..)
  14     , extMap
  15     , parseExtMap
  16     , guessTypeByFileName
  17     )
  18     where
  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
  24 import Data.Map (Map)
  25 import Data.Typeable
  26 import Data.List
  27 import Data.Monoid
  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
  39
  40 -- |A 'Map' from file extensions to 'MIMEType's.
  41 newtype ExtMap
  42     = ExtMap (Map Text MIMEType)
  43     deriving (Eq, Show, Read, Monoid, Typeable)
  44
  45 instance Lift ExtMap where
  46     lift (ExtMap m)
  47         = [| ExtMap $(liftMap liftText lift m) |]
  48
  49 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
  50 --
  51 -- @
  52 --   m :: 'ExtMap'
  53 --   m = ['extMap'|
  54 --   # MIME Type            Extensions
  55 --   application/xhtml+xml  xhtml
  56 --   image/jpeg             jpeg jpg
  57 --   image/png              png
  58 --   image/svg+xml          svg
  59 --   text/html              html
  60 --   text/plain             txt
  61 --   |]
  62 -- @
  63 extMap ∷ QuasiQuoter
  64 extMap = QuasiQuoter {
  65              quoteExp  = lift ∘ parseExtMap ∘ Lazy.pack
  66            , quotePat  = const unsupported
  67            , quoteType = const unsupported
  68            , quoteDec  = const unsupported
  69          }
  70     where
  71       unsupported ∷ Monad m ⇒ m α
  72       unsupported = fail "Unsupported usage of extMap quasi-quoter."
  73
  74 -- |Parse Apache @mime.types@.
  75 parseExtMap ∷ Lazy.ByteString → ExtMap
  76 parseExtMap src
  77     = case LP.parse pairs src of
  78         LP.Fail _ eCtx e
  79             → error $ "Unparsable extension map: "
  80                     ⧺ intercalate ", " eCtx
  81                     ⧺ ": "
  82                     ⧺ e
  83         LP.Done _ xs
  84             → case compile xs of
  85                  Right m → ExtMap m
  86                  Left  e → error ("Duplicate extension: " ⧺ show e)
  87     where
  88       pairs ∷ Parser [(MIMEType, [Text])]
  89       pairs = do skipMany linebreak
  90                  xs ← sepBy pair (skipMany1 linebreak)
  91                  skipMany linebreak
  92                  endOfInput
  93                  return xs
  94               <?>
  95               "pairs"
  96
  97       pair ∷ Parser (MIMEType, [Text])
  98       pair = do skipSpace
  99                 mime ← mimeType
 100                 skipSpace1
 101                 exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
 102                 return (mime, exts)
 103              <?>
 104              "pair"
 105
 106       ext ∷ Parser Text
 107       ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum)
 108             <?>
 109             "ext"
 110
 111       linebreak ∷ Parser ()
 112       linebreak
 113           = ( endOfLine
 114               <|>
 115               try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
 116             )
 117             <?>
 118             "linebreak"
 119
 120 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
 121 compile = go (∅) ∘ concat ∘ map tr
 122     where
 123       tr ∷ (v, [k]) → [(k, v)]
 124       tr (v, ks) = [(k, v) | k ← ks]
 125
 126       go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
 127       go m []         = Right m
 128       go m ((k, v):xs)
 129           = case M.insertLookupWithKey' f k v m of
 130               (Nothing, m') → go m' xs
 131               (Just v0, _ ) → Left (k, v0, v)
 132
 133       f ∷ k → v → v → v
 134       f _ _ = id
 135
 136 -- |Guess the MIME Type of a file.
 137 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
 138 guessTypeByFileName (ExtMap m) fpath
 139     = case takeExtension fpath of
 140         []      → Nothing
 141         (_:ext) → M.lookup (T.pack ext) m