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 Control.Monad
  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
  26 import Data.Map (Map)
  27 import Data.Maybe
  28 import Data.Typeable
  29 import Data.Monoid
  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
  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)
  49         = [| ExtMap $(liftMap liftText lift m) |]
  50
  51 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
  52 --
  53 -- @
  54 --   m :: 'ExtMap'
  55 --   m = ['extMap'|
  56 --   # MIME Type            Extensions
  57 --   application/xhtml+xml  xhtml
  58 --   image/jpeg             jpeg jpg
  59 --   image/png              png
  60 --   image/svg+xml          svg
  61 --   text/html              html
  62 --   text/plain             txt
  63 --   |]
  64 -- @
  65 extMap ∷ QuasiQuoter
  66 extMap = QuasiQuoter {
  67              quoteExp  = (lift ∘ parseExtMap =≪) ∘ toAscii
  68            , quotePat  = const unsupported
  69            , quoteType = const unsupported
  70            , quoteDec  = const unsupported
  71          }
  72     where
  73       toAscii ∷ Monad m ⇒ String → m Ascii
  74       toAscii (A.fromChars → Just a) = return a
  75       toAscii _ = fail "Malformed extension map"
  76
  77       unsupported ∷ Monad m ⇒ m α
  78       unsupported = fail "Unsupported usage of extMap quasi-quoter."
  79
  80 -- |Parse Apache @mime.types@.
  81 parseExtMap ∷ Ascii → ExtMap
  82 parseExtMap src
  83     = case parseOnly (finishOff extMapP) $ A.toByteString src of
  84         Right xs → case compile xs of
  85                       Right m → ExtMap m
  86                       Left  e → error ("Duplicate extension: " ⧺ show e)
  87         Left err → error ("Unparsable extension map: " ⧺ err)
  88
  89 extMapP ∷ Parser [(MIMEType, [Text])]
  90 extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
  91     where
  92       isSpc ∷ Char → Bool
  93       isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
  94
  95       comment ∷ Parser (Maybe (MIMEType, [Text]))
  96       comment = do skipWhile isSpc
  97                    void $ char '#'
  98                    skipWhile (≢ '\x0A')
  99                    return Nothing
 100
 101       validLine ∷ Parser (Maybe (MIMEType, [Text]))
 102       validLine = do skipWhile isSpc
 103                      mime ← mimeType
 104                      skipWhile isSpc
 105                      exts ← sepBy extP (skipWhile isSpc)
 106                      return $ Just (mime, exts)
 107
 108       extP ∷ Parser Text
 109       extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
 110
 111       emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
 112       emptyLine = do skipWhile isSpc
 113                      void $ char '\x0A'
 114                      return Nothing
 115
 116 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
 117 compile = go (∅) ∘ concat ∘ map tr
 118     where
 119       tr ∷ (v, [k]) → [(k, v)]
 120       tr (v, ks) = [(k, v) | k ← ks]
 121
 122       go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
 123       go m []         = Right m
 124       go m ((k, v):xs)
 125           = case M.insertLookupWithKey' f k v m of
 126               (Nothing, m') → go m' xs
 127               (Just v0, _ ) → Left (k, v0, v)
 128
 129       f ∷ k → v → v → v
 130       f _ _ = id
 131
 132 -- |Guess the MIME Type of a file.
 133 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
 134 guessTypeByFileName (ExtMap m) fpath
 135     = case takeExtension fpath of
 136         []      → Nothing
 137         (_:ext) → M.lookup (T.pack ext) m