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.Monoid.Unicode
  25 import Data.Text (Text)
  26 import qualified Data.Text as T
  27 import Data.Text.Encoding
  28 import Language.Haskell.Exts.Build
  29 import Language.Haskell.Exts.Extension
  30 import Language.Haskell.Exts.Pretty
  31 import Language.Haskell.Exts.Syntax
  32 import Network.HTTP.Lucu.MIMEType
  33 import Prelude.Unicode
  34 import System.FilePath
  35
  36 -- |'Map' from extension to 'MIMEType'.
  37 type ExtMap = Map Text MIMEType
  38
  39 -- |Guess the MIME Type of file.
  40 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
  41 guessTypeByFileName extMap fpath
  42     = case takeExtension fpath of
  43         []      → Nothing
  44         (_:ext) → M.lookup (T.pack ext) extMap
  45
  46 -- |Read an Apache mime.types and parse it.
  47 parseExtMapFile ∷ FilePath → IO ExtMap
  48 parseExtMapFile fpath
  49     = do file ← B.readFile fpath
  50          case LP.parse extMapP file of
  51            LP.Done _ xs
  52                → case compile xs of
  53                     Right m → return m
  54                     Left  e → fail (concat [ "Duplicate extension \""
  55                                            , show e
  56                                            , "\" in: "
  57                                            , fpath
  58                                            ])
  59            LP.Fail _ _ e
  60                → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
  61
  62 extMapP ∷ Parser [ (MIMEType, [Text]) ]
  63 extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
  64              endOfInput
  65              return $ catMaybes xs
  66     where
  67       isSpc ∷ Char → Bool
  68       isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
  69
  70       comment ∷ Parser (Maybe (MIMEType, [Text]))
  71       comment = try $
  72                 do skipWhile isSpc
  73                    _ ← char '#'
  74                    skipWhile (≢ '\x0A')
  75                    return Nothing
  76
  77       validLine ∷ Parser (Maybe (MIMEType, [Text]))
  78       validLine = try $
  79                   do skipWhile isSpc
  80                      mime ← mimeTypeP
  81                      skipWhile isSpc
  82                      exts ← sepBy extP (skipWhile isSpc)
  83                      return $ Just (mime, exts)
  84
  85       extP ∷ Parser Text
  86       extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
  87
  88       emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
  89       emptyLine = try $
  90                   do skipWhile isSpc
  91                      _ ← char '\x0A'
  92                      return Nothing
  93
  94 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
  95 compile = go (∅) ∘ concat ∘ map tr
  96     where
  97       tr ∷ (v, [k]) → [(k, v)]
  98       tr (v, ks) = [(k, v) | k ← ks]
  99
 100       go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
 101       go m []         = Right m
 102       go m ((k, v):xs)
 103           = case M.insertLookupWithKey' f k v m of
 104               (Nothing, m') → go m' xs
 105               (Just v0, _ ) → Left (k, v0, v)
 106
 107       f ∷ k → v → v → v
 108       f _ _ = id
 109
 110 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
 111 -- Haskell source code which contains the following things:
 112 --
 113 -- * A definition of module named @moduleName@.
 114 --
 115 -- * @variableName :: 'ExtMap'@ whose content is a serialization of
 116 --   @extMap@.
 117 --
 118 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
 119 -- surely generated using this function.
 120 serializeExtMap ∷ ExtMap → String → String → String
 121 serializeExtMap extMap moduleName variableName
 122     = let hsModule  = Module (⊥) (ModuleName moduleName) modPragma
 123                       Nothing (Just exports) imports decls
 124           modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
 125           exports   = [ EVar (UnQual (name variableName)) ]
 126           imports   = [ ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType")
 127                                    False False Nothing Nothing Nothing
 128                       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType.Guess")
 129                                    False False Nothing Nothing Nothing
 130                       , ImportDecl (⊥) (ModuleName "Data.Ascii")
 131                                    False False Nothing Nothing (Just (False, []))
 132                       , ImportDecl (⊥) (ModuleName "Data.Map")
 133                                    True False Nothing (Just (ModuleName "M")) Nothing
 134                       ]
 135           decls     = [ TypeSig (⊥) [name variableName]
 136                                     (TyCon (UnQual (name "ExtMap")))
 137                       , nameBind (⊥) (name variableName) extMapExp
 138                       ]
 139           comment   = concat [ "{- !!! WARNING !!!\n"
 140                              , "   This file is automatically generated.\n"
 141                              , "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
 142                              ]
 143           extMapExp = qvar (ModuleName "M") (name "fromList") `app` listE records
 144       in
 145         comment ⧺ prettyPrint hsModule ⧺ "\n"
 146     where
 147       records ∷ [Exp]
 148       records = map record $ M.assocs extMap
 149
 150       record ∷ (Text, MIMEType) → Exp
 151       record (ext, mime)
 152           = tuple [ strE (T.unpack ext)
 153                   , metaFunction "parseMIMEType" [strE $ mimeToString mime]
 154                   ]
 155
 156       mimeToString ∷ MIMEType → String
 157       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType