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 import           System.IO
  25
  26 -- |'Data.Map.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, _ #)
  44                -> return $ compile xs
  45
  46            (# _, input' #)
  47                -> let near = B.unpack $ B.take 100 input'
  48                   in
  49                     fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
  50
  51
  52 extMapP :: Parser [ (MIMEType, [String]) ]
  53 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
  54              eof
  55              return $ catMaybes xs
  56     where
  57       spc = oneOf " \t"
  58
  59       comment = do many spc
  60                    char '#'
  61                    many $ satisfy (/= '\n')
  62                    return Nothing
  63
  64       validLine = do many spc
  65                      mime <- mimeTypeP
  66                      many spc
  67                      exts <- sepBy token (many spc)
  68                      return $ Just (mime, exts)
  69
  70       emptyLine = oneOf " \t\n" >> return Nothing
  71
  72
  73 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
  74 compile = M.fromList . foldr (++) [] . map tr
  75     where
  76       tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
  77       tr (mime, exts) = [ (ext, mime) | ext <- exts ]
  78
  79 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
  80 -- Haskell source code which contains the following things:
  81 --
  82 -- * A definition of module named @moduleName@.
  83 --
  84 -- * @variableName :: 'ExtMap'@ whose content is a serialization of
  85 --   @extMap@.
  86 --
  87 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
  88 -- surely generated using this function.
  89 serializeExtMap :: ExtMap -> String -> String -> String
  90 serializeExtMap extMap moduleName variableName
  91     = let hsModule = HsModule undefined modName (Just exports) imports decls
  92           modName  = Module moduleName
  93           exports  = [HsEVar (UnQual (HsIdent variableName))]
  94           imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, []))
  95                      , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
  96                      , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
  97                      ]
  98           decls    = [ HsTypeSig undefined [HsIdent variableName]
  99                                      (HsQualType []
 100                                       (HsTyCon (UnQual (HsIdent "ExtMap"))))
 101                      , HsFunBind [HsMatch undefined (HsIdent variableName)
 102                                   [] (HsUnGuardedRhs extMapExp) []]
 103                      ]
 104           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
 105           comment   =    "{- !!! WARNING !!!\n"
 106                       ++ "   This file is automatically generated.\n"
 107                       ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
 108       in
 109         comment ++ prettyPrint hsModule ++ "\n"
 110     where
 111       records :: [HsExp]
 112       records = map record $ M.assocs extMap
 113
 114       record :: (String, MIMEType) -> HsExp
 115       record (ext, mime)
 116           = HsTuple [HsLit (HsString ext), mimeToExp mime]
 117
 118       mimeToExp :: MIMEType -> HsExp
 119       mimeToExp mt
 120           = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))