Network/HTTP/Lucu/MIMEType/Guess.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , UnboxedTuples
   4   , UnicodeSyntax
   5   #-}
   6 -- |MIME Type guessing by a file extension. This is a poor man's way
   7 -- of guessing MIME Types. It is simple and fast.
   8 --
   9 -- In general you don't have to use this module directly.
  10 module Network.HTTP.Lucu.MIMEType.Guess
  11     ( ExtMap
  12     , guessTypeByFileName
  13
  14     , parseExtMapFile
  15     , serializeExtMap
  16     )
  17     where
  18 import Control.Applicative
  19 import qualified Data.Ascii as A
  20 import Data.Attoparsec.Char8 as P
  21 import qualified Data.Attoparsec.Lazy as AL
  22 import qualified Data.ByteString.Lazy.Char8 as B
  23 import qualified Data.Map as M
  24 import Data.Map (Map)
  25 import Data.Maybe
  26 import Data.Text (Text)
  27 import qualified Data.Text as T
  28 import Data.Text.Encoding
  29 import Language.Haskell.Pretty
  30 import Language.Haskell.Syntax
  31 import Network.HTTP.Lucu.MIMEType
  32 import Prelude.Unicode
  33 import System.FilePath
  34
  35 -- |'Map' from extension to 'MIMEType'.
  36 type ExtMap = Map Text MIMEType
  37
  38 -- |Guess the MIME Type of file.
  39 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
  40 guessTypeByFileName !extMap !fpath
  41     = let ext = T.pack $ takeExtension fpath
  42       in
  43         M.lookup ext extMap
  44
  45 -- |Read an Apache mime.types and parse it.
  46 parseExtMapFile ∷ FilePath → IO ExtMap
  47 parseExtMapFile fpath
  48     = do file ← B.readFile fpath
  49          case AL.parse extMapP file of
  50            AL.Done _ xs  → return $ compile xs
  51            AL.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
  52
  53 extMapP ∷ Parser [ (MIMEType, [Text]) ]
  54 extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
  55              endOfInput
  56              return $ catMaybes xs
  57     where
  58       isSpc ∷ Char → Bool
  59       isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
  60
  61       comment ∷ Parser (Maybe (MIMEType, [Text]))
  62       comment = try $
  63                 do skipWhile isSpc
  64                    _ ← char '#'
  65                    skipWhile (≢ '\x0A')
  66                    return Nothing
  67
  68       validLine ∷ Parser (Maybe (MIMEType, [Text]))
  69       validLine = try $
  70                   do skipWhile isSpc
  71                      mime ← mimeTypeP
  72                      skipWhile isSpc
  73                      exts ← sepBy extP (skipWhile isSpc)
  74                      return $ Just (mime, exts)
  75
  76       extP ∷ Parser Text
  77       extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
  78
  79       emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
  80       emptyLine = try $
  81                   do skipWhile isSpc
  82                      _ ← char '\x0A'
  83                      return Nothing
  84
  85 compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType
  86 compile = M.fromList ∘ concat ∘ map tr
  87     where
  88       tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ]
  89       tr (mime, exts) = [ (ext, mime) | ext ← exts ]
  90
  91 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
  92 -- Haskell source code which contains the following things:
  93 --
  94 -- * A definition of module named @moduleName@.
  95 --
  96 -- * @variableName ∷ 'ExtMap'@ whose content is a serialization of
  97 --   @extMap@.
  98 --
  99 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
 100 -- surely generated using this function.
 101 serializeExtMap ∷ ExtMap → String → String → String
 102 serializeExtMap extMap moduleName variableName
 103     = let hsModule = HsModule (⊥) modName (Just exports) imports decls
 104           modName  = Module moduleName
 105           exports  = [HsEVar (UnQual (HsIdent variableName))]
 106           imports  = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
 107                      , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
 108                      , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing
 109                      , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing
 110                      , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing
 111                      ]
 112           decls    = [ HsTypeSig (⊥) [HsIdent variableName]
 113                                      (HsQualType []
 114                                       (HsTyCon (UnQual (HsIdent "ExtMap"))))
 115                      , HsFunBind [HsMatch (⊥) (HsIdent variableName)
 116                                   [] (HsUnGuardedRhs extMapExp) []]
 117                      ]
 118           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
 119           comment   =    "{- !!! WARNING !!!\n"
 120                       ++ "   This file is automatically generated.\n"
 121                       ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
 122       in
 123         comment ++ prettyPrint hsModule ++ "\n"
 124     where
 125       records ∷ [HsExp]
 126       records = map record $ M.assocs extMap
 127
 128       record ∷ (Text, MIMEType) → HsExp
 129       record (ext, mime)
 130           = HsTuple
 131             [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack")))
 132                     (HsLit (HsString (T.unpack ext)))
 133             , mimeToExp mime
 134             ]
 135
 136       mimeToExp ∷ MIMEType → HsExp
 137       mimeToExp mt
 138           = HsApp (HsVar (UnQual (HsIdent "parseMIMEType")))
 139             (HsParen
 140              (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString")))
 141               (HsLit (HsString $ A.toString $ printMIMEType mt))))