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
  21 import qualified Data.Attoparsec.Lazy as LP
  22 import qualified Data.ByteString.Lazy.Char8 as Lazy
  23 import Data.Convertible.Base
  24 import Data.Convertible.Instances.Text ()
  25 import qualified Data.Map as M
  26 import Data.Map (Map)
  27 import Data.Typeable
  28 import Data.List
  29 import Data.Monoid
  30 import Data.Monoid.Unicode
  31 import Data.Text (Text)
  32 import Data.Text.Encoding
  33 import Language.Haskell.TH.Syntax
  34 import Language.Haskell.TH.Quote
  35 import Network.HTTP.Lucu.MIMEType
  36 import Network.HTTP.Lucu.OrphanInstances ()
  37 import Network.HTTP.Lucu.Parser
  38 import Prelude.Unicode
  39 import System.FilePath
  40
  41 -- |A 'Map' from file extensions to 'MIMEType's.
  42 newtype ExtMap
  43     = ExtMap (Map Text MIMEType)
  44     deriving (Eq, Show, Read, Monoid, Typeable)
  45
  46 instance Lift ExtMap where
  47     lift (ExtMap m) = [| ExtMap $(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 <$> 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 ∘ (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 (cs ext) m