Network/HTTP/Lucu/MIMEType/Guess.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 -- |MIME Type guessing by a file extension. This is a poor man's way
   5 -- of guessing MIME Types. It is simple and fast.
   6 --
   7 -- In general you don't have to use this module directly.
   8 module Network.HTTP.Lucu.MIMEType.Guess
   9     ( ExtMap
  10     , guessTypeByFileName
  11
  12     , parseExtMapFile
  13     , serializeExtMap
  14     )
  15     where
  16 import Control.Applicative
  17 import qualified Data.Ascii as A
  18 import Data.Attoparsec.Char8 as P
  19 import qualified Data.Attoparsec.Lazy as LP
  20 import qualified Data.ByteString.Lazy.Char8 as B
  21 import qualified Data.Map as M
  22 import Data.Map (Map)
  23 import Data.Maybe
  24 import Data.Text (Text)
  25 import qualified Data.Text as T
  26 import Data.Text.Encoding
  27 import Language.Haskell.Exts.Build
  28 import Language.Haskell.Exts.Extension
  29 import Language.Haskell.Exts.Pretty
  30 import Language.Haskell.Exts.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 LP.parse extMapP file of
  50            LP.Done _ xs  → return $ compile xs
  51            LP.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  = Module (⊥) (ModuleName moduleName) modPragma
 104                       Nothing (Just exports) imports decls
 105           modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
 106           exports   = [ EVar (UnQual (name variableName)) ]
 107           imports   = [ ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType")
 108                                    False False Nothing Nothing Nothing
 109                       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType.Guess")
 110                                    False False Nothing Nothing Nothing
 111                       , ImportDecl (⊥) (ModuleName "Data.Ascii")
 112                                    False False Nothing Nothing (Just (False, []))
 113                       , ImportDecl (⊥) (ModuleName "Data.Map")
 114                                    True False Nothing (Just (ModuleName "M")) Nothing
 115                       ]
 116           decls     = [ TypeSig (⊥) [name variableName]
 117                                     (TyCon (UnQual (name "ExtMap")))
 118                       , nameBind (⊥) (name variableName) extMapExp
 119                       ]
 120           comment   = concat [ "{- !!! WARNING !!!\n"
 121                              , "   This file is automatically generated.\n"
 122                              , "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
 123                              ]
 124           extMapExp = qvar (ModuleName "M") (name "fromList") `app` listE records
 125       in
 126         comment ⧺ prettyPrint hsModule ⧺ "\n"
 127     where
 128       records ∷ [Exp]
 129       records = map record $ M.assocs extMap
 130
 131       record ∷ (Text, MIMEType) → Exp
 132       record (ext, mime)
 133           = tuple [ strE (T.unpack ext)
 134                   , metaFunction "parseMIMEType" [strE $ mimeToString mime]
 135                   ]
 136
 137       mimeToString ∷ MIMEType → String
 138       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType