Network/HTTP/Lucu/MIMEType/Guess.hs

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