X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=3e3df1631b7af87c29012159681bc2474df5c10f;hb=ca338174155913a969808d7b20193973394e474e;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..3e3df16 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,117 +1,143 @@ +{-# LANGUAGE + BangPatterns + , 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 Control.Applicative +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import qualified Data.Attoparsec.Lazy as LP 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 - -type ExtMap = Map String MIMEType - - -guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType -guessTypeByFileName extMap fpath - = let ext = last $ splitBy (== '.') fpath +import Data.Map (Map) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Language.Haskell.Pretty +import Language.Haskell.Syntax +import Network.HTTP.Lucu.MIMEType +import Prelude.Unicode +import System.FilePath + +-- |'Map' from extension to 'MIMEType'. +type ExtMap = Map Text MIMEType + +-- |Guess the MIME Type of file. +guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType +guessTypeByFileName !extMap !fpath + = let ext = T.pack $ takeExtension fpath in - M.lookup ext extMap >>= return - + M.lookup ext extMap -parseExtMapFile :: FilePath -> IO ExtMap +-- |Read an Apache mime.types and parse it. +parseExtMapFile ∷ FilePath → IO ExtMap parseExtMapFile fpath - = 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 ++ ")") - - -extMapP :: Parser [ (MIMEType, [String]) ] -extMapP = do xs <- many (comment <|> validLine <|> emptyLine) - eof + = do file ← B.readFile fpath + case LP.parse extMapP file of + LP.Done _ xs → return $ compile xs + LP.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) + +extMapP ∷ Parser [ (MIMEType, [Text]) ] +extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) + endOfInput return $ catMaybes xs where - spc = oneOf " \t" - - comment = do many spc - char '#' - many $ satisfy (/= '\n') + isSpc ∷ Char → Bool + isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' + + comment ∷ Parser (Maybe (MIMEType, [Text])) + comment = try $ + do skipWhile isSpc + _ ← char '#' + skipWhile (≢ '\x0A') return Nothing - validLine = do many spc - mime <- mimeTypeP - many spc - exts <- sepBy token (many spc) + validLine ∷ Parser (Maybe (MIMEType, [Text])) + validLine = try $ + do skipWhile isSpc + mime ← mimeTypeP + skipWhile isSpc + exts ← sepBy extP (skipWhile isSpc) return $ Just (mime, exts) - emptyLine = oneOf " \t\n" >> return Nothing + extP ∷ Parser Text + extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A')) + emptyLine ∷ Parser (Maybe (MIMEType, [Text])) + emptyLine = try $ + do skipWhile isSpc + _ ← char '\x0A' + return Nothing -compile :: [ (MIMEType, [String]) ] -> Map String MIMEType -compile = M.fromList . foldr (++) [] . map tr +compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType +compile = M.fromList ∘ concat ∘ map tr where - tr :: (MIMEType, [String]) -> [ (String, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext <- exts ] - - -outputExtMapAsHS :: ExtMap -> FilePath -> IO () -outputExtMapAsHS extMap fpath - = 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 - , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing - , HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")])) + tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ] + tr (mime, exts) = [ (ext, mime) | ext ← exts ] + +-- |@'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 (⊥) modName (Just exports) imports decls + modName = Module moduleName + exports = [HsEVar (UnQual (HsIdent variableName))] + imports = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing + , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing + , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing + , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing + , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing ] - 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 (⊥) [HsIdent variableName] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ExtMap")))) + , HsFunBind [HsMatch (⊥) (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 ∷ [HsExp] records = map record $ M.assocs extMap - record :: (String, MIMEType) -> HsExp + record ∷ (Text, MIMEType) → HsExp record (ext, mime) - = HsTuple [HsLit (HsString ext), mimeToExp mime] + = HsTuple + [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack"))) + (HsLit (HsString (T.unpack 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 ∷ MIMEType → HsExp + mimeToExp mt + = HsApp (HsVar (UnQual (HsIdent "parseMIMEType"))) + (HsParen + (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString"))) + (HsLit (HsString $ mimeToString mt)))) + + mimeToString ∷ MIMEType → String + mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType