Network/HTTP/Lucu/MIMEType/Guess.hs

   1 -- |MIME Type guessing by a file extension. This is a poor man's way
   2 -- of guessing MIME Types. It is simple and fast.
   3 --
   4 -- In general you don't have to use this module directly.
   5 module Network.HTTP.Lucu.MIMEType.Guess
   6     ( ExtMap
   7     , guessTypeByFileName
   8
   9     , parseExtMapFile
  10     , serializeExtMap
  11     )
  12     where
  13
  14 import qualified Data.ByteString.Lazy.Char8 as B
  15 import qualified Data.Map as M
  16 import           Data.Map (Map)
  17 import           Data.Maybe
  18 import           Language.Haskell.Pretty
  19 import           Language.Haskell.Syntax
  20 import           Network.HTTP.Lucu.MIMEType
  21 import           Network.HTTP.Lucu.Parser
  22 import           Network.HTTP.Lucu.Parser.Http
  23 import           Network.HTTP.Lucu.Utils
  24
  25 -- |'Data.Map.Map' from extension to MIME Type.
  26 type ExtMap = Map String MIMEType
  27
  28 -- |Guess the MIME Type of file.
  29 guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
  30 guessTypeByFileName extMap fpath
  31     = extMap `seq` fpath `seq`
  32       let ext = last $ splitBy (== '.') fpath
  33       in
  34         M.lookup ext extMap >>= return
  35
  36 -- |Read an Apache mime.types and parse it.
  37 parseExtMapFile :: FilePath -> IO ExtMap
  38 parseExtMapFile fpath
  39     = fpath `seq`
  40       do file <- B.readFile fpath
  41          case parse (allowEOF extMapP) file of
  42            (# Success xs, _ #)
  43                -> return $ compile xs
  44
  45            (# _, input' #)
  46                -> let near = B.unpack $ B.take 100 input'
  47                   in
  48                     fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
  49
  50
  51 extMapP :: Parser [ (MIMEType, [String]) ]
  52 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
  53              eof
  54              return $ catMaybes xs
  55     where
  56       spc = oneOf " \t"
  57
  58       comment = many spc >>
  59                 char '#' >>
  60                 ( many $ satisfy (/= '\n') ) >>
  61                 return Nothing
  62
  63       validLine = do _    <- many spc
  64                      mime <- mimeTypeP
  65                      _    <- many spc
  66                      exts <- sepBy token (many spc)
  67                      return $ Just (mime, exts)
  68
  69       emptyLine = oneOf " \t\n" >> return Nothing
  70
  71
  72 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
  73 compile = M.fromList . foldr (++) [] . map tr
  74     where
  75       tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
  76       tr (mime, exts) = [ (ext, mime) | ext <- exts ]
  77
  78 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
  79 -- Haskell source code which contains the following things:
  80 --
  81 -- * A definition of module named @moduleName@.
  82 --
  83 -- * @variableName :: 'ExtMap'@ whose content is a serialization of
  84 --   @extMap@.
  85 --
  86 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
  87 -- surely generated using this function.
  88 serializeExtMap :: ExtMap -> String -> String -> String
  89 serializeExtMap extMap moduleName variableName
  90     = let hsModule = HsModule undefined modName (Just exports) imports decls
  91           modName  = Module moduleName
  92           exports  = [HsEVar (UnQual (HsIdent variableName))]
  93           imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, []))
  94                      , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
  95                      , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
  96                      ]
  97           decls    = [ HsTypeSig undefined [HsIdent variableName]
  98                                      (HsQualType []
  99                                       (HsTyCon (UnQual (HsIdent "ExtMap"))))
 100                      , HsFunBind [HsMatch undefined (HsIdent variableName)
 101                                   [] (HsUnGuardedRhs extMapExp) []]
 102                      ]
 103           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
 104           comment   =    "{- !!! WARNING !!!\n"
 105                       ++ "   This file is automatically generated.\n"
 106                       ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
 107       in
 108         comment ++ prettyPrint hsModule ++ "\n"
 109     where
 110       records :: [HsExp]
 111       records = map record $ M.assocs extMap
 112
 113       record :: (String, MIMEType) -> HsExp
 114       record (ext, mime)
 115           = HsTuple [HsLit (HsString ext), mimeToExp mime]
 116
 117       mimeToExp :: MIMEType -> HsExp
 118       mimeToExp mt
 119           = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))