Network/HTTP/Lucu/MIMEType/Guess.hs

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