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 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.OrphanInstances ()
  36 import Network.HTTP.Lucu.Parser
  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) = [| ExtMap $(lift m) |]
  47
  48 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
  49 --
  50 -- @
  51 --   m :: 'ExtMap'
  52 --   m = ['extMap'|
  53 --   # MIME Type            Extensions
  54 --   application/xhtml+xml  xhtml
  55 --   image/jpeg             jpeg jpg
  56 --   image/png              png
  57 --   image/svg+xml          svg
  58 --   text/html              html
  59 --   text/plain             txt
  60 --   |]
  61 -- @
  62 extMap ∷ QuasiQuoter
  63 extMap = QuasiQuoter {
  64              quoteExp  = lift ∘ parseExtMap ∘ Lazy.pack
  65            , quotePat  = const unsupported
  66            , quoteType = const unsupported
  67            , quoteDec  = const unsupported
  68          }
  69     where
  70       unsupported ∷ Monad m ⇒ m α
  71       unsupported = fail "Unsupported usage of extMap quasi-quoter."
  72
  73 -- |Parse Apache @mime.types@.
  74 parseExtMap ∷ Lazy.ByteString → ExtMap
  75 parseExtMap src
  76     = case LP.parse pairs src of
  77         LP.Fail _ eCtx e
  78             → error $ "Unparsable extension map: "
  79                     ⧺ intercalate ", " eCtx
  80                     ⧺ ": "
  81                     ⧺ e
  82         LP.Done _ xs
  83             → case compile xs of
  84                  Right m → ExtMap m
  85                  Left  e → error ("Duplicate extension: " ⧺ show e)
  86     where
  87       pairs ∷ Parser [(MIMEType, [Text])]
  88       pairs = do skipMany linebreak
  89                  xs ← sepBy pair (skipMany1 linebreak)
  90                  skipMany linebreak
  91                  endOfInput
  92                  return xs
  93               <?>
  94               "pairs"
  95
  96       pair ∷ Parser (MIMEType, [Text])
  97       pair = do skipSpace
  98                 mime ← mimeType
  99                 skipSpace1
 100                 exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
 101                 return (mime, exts)
 102              <?>
 103              "pair"
 104
 105       ext ∷ Parser Text
 106       ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
 107             <?>
 108             "ext"
 109
 110       linebreak ∷ Parser ()
 111       linebreak
 112           = ( endOfLine
 113               <|>
 114               try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
 115             )
 116             <?>
 117             "linebreak"
 118
 119 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
 120 compile = go (∅) ∘ concat ∘ (tr <$>)
 121     where
 122       tr ∷ (v, [k]) → [(k, v)]
 123       tr (v, ks) = [(k, v) | k ← ks]
 124
 125       go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
 126       go m []         = Right m
 127       go m ((k, v):xs)
 128           = case M.insertLookupWithKey' f k v m of
 129               (Nothing, m') → go m' xs
 130               (Just v0, _ ) → Left (k, v0, v)
 131
 132       f ∷ k → v → v → v
 133       f _ _ = id
 134
 135 -- |Guess the MIME Type of a file.
 136 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
 137 guessTypeByFileName (ExtMap m) fpath
 138     = case takeExtension fpath of
 139         []      → Nothing
 140         (_:ext) → M.lookup (T.pack ext) m