X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=39de37e07d68464b8029021f745e956fa236c036;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=309f7fe0621a427ca1fb1ed0bb1ec09e90e3acee;hpb=c6b11025d1f81c668e9995e856b7bb34175230d3;p=Lucu.git diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 309f7fe..39de37e 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,11 +1,21 @@ +{-# 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 - ( parseExtMapFile -- FilePath -> IO (Map String MIMEType) - , outputExtMapAsHS -- Map String MIMEType -> FilePath -> IO () + ( ExtMap + , guessTypeByFileName + + , 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 @@ -14,18 +24,32 @@ import Language.Haskell.Syntax import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http -import System.IO +import Network.HTTP.Lucu.Utils + +-- |'Data.Map.Map' from extension to MIME Type. +type ExtMap = Map String MIMEType -import Debug.Trace +-- |Guess the MIME Type of file. +guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType +guessTypeByFileName extMap fpath + = extMap `seq` fpath `seq` + let ext = last $ splitBy (== '.') fpath + in + M.lookup ext extMap >>= return -parseExtMapFile :: FilePath -> IO (Map String MIMEType) +-- |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]) ] @@ -35,14 +59,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) @@ -55,29 +79,37 @@ compile = M.fromList . foldr (++) [] . map tr tr :: (MIMEType, [String]) -> [ (String, MIMEType) ] tr (mime, exts) = [ (ext, mime) | ext <- exts ] - -outputExtMapAsHS :: Map String MIMEType -> 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 @@ -87,19 +119,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))