X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=5a10bb60bd7e16ee6ae008534c8c5cc914568cb5;hb=9bb89434103e9a22f100d6ecb7e65a5d461e0454;hp=db51e65cdce31d6bef85c93aeb32fe786ed51af1;hpb=175e14b3b144537644e65ca76f1fca5c56fd44e9;p=Lucu.git diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index db51e65..5a10bb6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,43 +1,53 @@ +{-# LANGUAGE + UnboxedTuples + , UnicodeSyntax + #-} +-- |MIME Type guessing by a file extension. This is a poor man's way +-- of guessing MIME Types. It is simple and fast. +-- +-- In general you don't have to use this module directly. module Network.HTTP.Lucu.MIMEType.Guess ( ExtMap - , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType + , guessTypeByFileName - , parseExtMapFile -- FilePath -> IO ExtMap - , outputExtMapAsHS -- ExtMap -> FilePath -> IO () + , parseExtMapFile + , serializeExtMap ) where - import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe -import Language.Haskell.Pretty -import Language.Haskell.Syntax -import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils -import System.IO - +import Data.Map (Map) +import Data.Maybe +import Language.Haskell.Pretty +import Language.Haskell.Syntax +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils + +-- |'Data.Map.Map' from extension to MIME Type. type ExtMap = Map String MIMEType - +-- |Guess the MIME Type of file. guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType guessTypeByFileName extMap fpath - = let ext = last $ splitBy (== '.') fpath + = extMap `seq` fpath `seq` + let ext = last $ splitBy (== '.') fpath in M.lookup ext extMap >>= return - +-- |Read an Apache mime.types and parse it. parseExtMapFile :: FilePath -> IO ExtMap parseExtMapFile fpath - = do file <- B.readFile fpath + = fpath `seq` + do file <- B.readFile fpath case parse (allowEOF extMapP) file of - (Success xs, _) -> return $ compile xs - (_, input') -> let near = B.unpack $ B.take 100 input' - in - fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")") + (# Success xs, _ #) + -> return $ compile xs + + (# _, input' #) + -> let near = B.unpack $ B.take 100 input' + in + fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")") extMapP :: Parser [ (MIMEType, [String]) ] @@ -47,14 +57,14 @@ extMapP = do xs <- many (comment <|> validLine <|> emptyLine) where spc = oneOf " \t" - comment = do many spc - char '#' - many $ satisfy (/= '\n') - return Nothing + comment = many spc >> + char '#' >> + ( many $ satisfy (/= '\n') ) >> + return Nothing - validLine = do many spc + validLine = do _ <- many spc mime <- mimeTypeP - many spc + _ <- many spc exts <- sepBy token (many spc) return $ Just (mime, exts) @@ -67,29 +77,37 @@ compile = M.fromList . foldr (++) [] . map tr tr :: (MIMEType, [String]) -> [ (String, MIMEType) ] tr (mime, exts) = [ (ext, mime) | ext <- exts ] - -outputExtMapAsHS :: ExtMap -> FilePath -> IO () -outputExtMapAsHS extMap fpath +-- |@'serializeExtMap' extMap moduleName variableName@ generates a +-- Haskell source code which contains the following things: +-- +-- * A definition of module named @moduleName@. +-- +-- * @variableName :: 'ExtMap'@ whose content is a serialization of +-- @extMap@. +-- +-- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is +-- surely generated using this function. +serializeExtMap :: ExtMap -> String -> String -> String +serializeExtMap extMap moduleName variableName = let hsModule = HsModule undefined modName (Just exports) imports decls - modName = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" - exports = [HsEVar (UnQual (HsIdent "defaultExtensionMap"))] - imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing + modName = Module moduleName + exports = [HsEVar (UnQual (HsIdent variableName))] + imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, [])) + , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing - , HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")])) ] - decls = [ HsTypeSig undefined [HsIdent "defaultExtensionMap"] - (HsQualType [] (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Map"))) - (HsTyCon (UnQual (HsIdent "String")))) - (HsTyCon (UnQual (HsIdent "MIMEType"))))) - , HsFunBind [HsMatch undefined (HsIdent "defaultExtensionMap") + decls = [ HsTypeSig undefined [HsIdent variableName] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ExtMap")))) + , HsFunBind [HsMatch undefined (HsIdent variableName) [] (HsUnGuardedRhs extMapExp) []] ] extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records) - comment = "{- !!! WARNING !!!\n" - ++ " This file is automatically generated from data/mime.types.\n" - ++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" + comment = "{- !!! WARNING !!!\n" + ++ " This file is automatically generated.\n" + ++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" in - writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n" + comment ++ prettyPrint hsModule ++ "\n" where records :: [HsExp] records = map record $ M.assocs extMap @@ -99,19 +117,5 @@ outputExtMapAsHS extMap fpath = HsTuple [HsLit (HsString ext), mimeToExp mime] mimeToExp :: MIMEType -> HsExp - mimeToExp (MIMEType maj min params) - = foldl appendParam (HsInfixApp - (HsLit (HsString maj)) - (HsQVarOp (UnQual (HsSymbol ""))) - (HsLit (HsString min))) params - - appendParam :: HsExp -> (String, String) -> HsExp - appendParam x param - = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "<:>"))) $ paramToExp param - - paramToExp :: (String, String) -> HsExp - paramToExp (name, value) - = HsInfixApp - (HsLit (HsString name)) - (HsQVarOp (UnQual (HsSymbol "<=>"))) - (HsLit (HsString value)) \ No newline at end of file + mimeToExp mt + = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))