Network/HTTP/Lucu/MIMEType/Guess.hs

   1 -- |MIME Type guesser which guesses by a file extension. This is a
   2 -- poor man's way 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 import           System.IO
  25
  26 -- |Map from extension to MIME Type.
  27 type ExtMap = Map String MIMEType
  28
  29 -- |Guess the MIME Type of file.
  30 guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
  31 guessTypeByFileName extMap fpath
  32     = extMap `seq` fpath `seq`
  33       let ext = last $ splitBy (== '.') fpath
  34       in
  35         M.lookup ext extMap >>= return
  36
  37 -- |Read an Apache mime.types and parse it.
  38 parseExtMapFile :: FilePath -> IO ExtMap
  39 parseExtMapFile fpath
  40     = fpath `seq`
  41       do file <- B.readFile fpath
  42          case parse (allowEOF extMapP) file of
  43            (Success xs, _) -> return $ compile xs
  44            (_, input')     -> let near = B.unpack $ B.take 100 input'
  45                               in
  46                                 fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
  47
  48
  49 extMapP :: Parser [ (MIMEType, [String]) ]
  50 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
  51              eof
  52              return $ catMaybes xs
  53     where
  54       spc = oneOf " \t"
  55
  56       comment = do many spc
  57                    char '#'
  58                    many $ satisfy (/= '\n')
  59                    return Nothing
  60
  61       validLine = do many spc
  62                      mime <- mimeTypeP
  63                      many spc
  64                      exts <- sepBy token (many spc)
  65                      return $ Just (mime, exts)
  66
  67       emptyLine = oneOf " \t\n" >> return Nothing
  68
  69
  70 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
  71 compile = M.fromList . foldr (++) [] . map tr
  72     where
  73       tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
  74       tr (mime, exts) = [ (ext, mime) | ext <- exts ]
  75
  76 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
  77 -- Haskell source code which contains the following things:
  78 --
  79 -- * A definition of module named @moduleName@.
  80 --
  81 -- * @variableName :: 'ExtMap'@ whose content is a serialization of
  82 --   @extMap@.
  83 --
  84 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
  85 -- surely generated using this function.
  86 serializeExtMap :: ExtMap -> String -> String -> String
  87 serializeExtMap extMap moduleName variableName
  88     = let hsModule = HsModule undefined modName (Just exports) imports decls
  89           modName  = Module moduleName
  90           exports  = [HsEVar (UnQual (HsIdent variableName))]
  91           imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
  92                      , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
  93                      , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
  94                      ]
  95           decls    = [ HsTypeSig undefined [HsIdent variableName]
  96                                      (HsQualType []
  97                                       (HsTyCon (UnQual (HsIdent "ExtMap"))))
  98                      , HsFunBind [HsMatch undefined (HsIdent variableName)
  99                                   [] (HsUnGuardedRhs extMapExp) []]
 100                      ]
 101           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
 102           comment =    "{- !!! WARNING !!!\n"
 103                     ++ "   This file is automatically generated.\n"
 104                     ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
 105       in
 106         comment ++ prettyPrint hsModule ++ "\n"
 107     where
 108       records :: [HsExp]
 109       records = map record $ M.assocs extMap
 110
 111       record :: (String, MIMEType) -> HsExp
 112       record (ext, mime)
 113           = HsTuple [HsLit (HsString ext), mimeToExp mime]
 114
 115       mimeToExp :: MIMEType -> HsExp
 116       mimeToExp (MIMEType maj min params)
 117           = foldl appendParam (HsInfixApp
 118                                (HsLit (HsString maj))
 119                                (HsQVarOp (UnQual (HsSymbol "</>")))
 120                                (HsLit (HsString min))) params
 121
 122       appendParam :: HsExp -> (String, String) -> HsExp
 123       appendParam x param
 124           = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "<:>"))) $ paramToExp param
 125
 126       paramToExp :: (String, String) -> HsExp
 127       paramToExp (name, value)
 128           = HsInfixApp
 129             (HsLit (HsString name))
 130             (HsQVarOp (UnQual (HsSymbol "<=>")))
 131             (HsLit (HsString value))