X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=05d0cd606f383eccdbef688a39dfa4f1e215b3d5;hp=db51e65cdce31d6bef85c93aeb32fe786ed51af1;hb=90fca0675b1694e69b8e431c989343855cbd125d;hpb=175e14b3b144537644e65ca76f1fca5c56fd44e9 diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index db51e65..05d0cd6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,117 +1,144 @@ +{-# LANGUAGE + DeriveDataTypeable + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , TemplateHaskell + , UnicodeSyntax + , ViewPatterns + #-} +-- |Guessing MIME Types by file extensions. It's not always accurate +-- but 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 - - , parseExtMapFile -- FilePath -> IO ExtMap - , outputExtMapAsHS -- ExtMap -> FilePath -> IO () + ( ExtMap(..) + , extMap + , guessTypeByFileName ) where - -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import Control.Applicative +import Data.Attoparsec.Char8 +import qualified Data.Attoparsec.Lazy as LP +import qualified Data.ByteString.Lazy.Char8 as Lazy +import Data.Convertible.Base +import Data.Convertible.Instances.Text () +import Data.Default 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 - in - M.lookup ext extMap >>= return - - -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 - return $ catMaybes xs - where - spc = oneOf " \t" - - comment = do many spc - char '#' - many $ satisfy (/= '\n') - return Nothing - - validLine = do many spc - mime <- mimeTypeP - many spc - exts <- sepBy token (many spc) - return $ Just (mime, exts) - - emptyLine = oneOf " \t\n" >> return Nothing - - -compile :: [ (MIMEType, [String]) ] -> Map String MIMEType -compile = M.fromList . foldr (++) [] . map tr +import Data.Map (Map) +import Data.Typeable +import Data.List +import Data.Monoid +import Data.Monoid.Unicode +import Data.Text (Text) +import Data.Text.Encoding +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.OrphanInstances () +import Network.HTTP.Lucu.Parser +import Prelude.Unicode +import System.FilePath + +-- |A 'Map' from file extensions to 'MIMEType's. +newtype ExtMap + = ExtMap (Map Text MIMEType) + deriving (Eq, Show, Read, Monoid, Typeable) + +instance Lift ExtMap where + lift (ExtMap m) = [| ExtMap $(lift m) |] + +-- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@. +-- +-- @ +-- m :: 'ExtMap' +-- m = ['extMap'| +-- # MIME Type Extensions +-- application/xhtml+xml xhtml +-- image/jpeg jpeg jpg +-- image/png png +-- image/svg+xml svg +-- text/html html +-- text/plain txt +-- |] +-- @ +extMap ∷ QuasiQuoter +extMap = QuasiQuoter { + quoteExp = lift ∘ parseExtMap ∘ Lazy.pack + , quotePat = const unsupported + , quoteType = const unsupported + , quoteDec = const unsupported + } 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")])) - ] - 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") - [] (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" - in - writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n" + parseExtMap ∷ Lazy.ByteString → ExtMap + parseExtMap = convertUnsafe + + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of extMap quasi-quoter." + +instance ConvertAttempt Lazy.ByteString ExtMap where + convertAttempt src + = case LP.parse pairs src of + LP.Fail _ eCtx e + → fail $ "Unparsable extension map: " + ⊕ intercalate ", " eCtx + ⊕ ": " + ⊕ e + LP.Done _ xs + → case compile xs of + Right m → return $ ExtMap m + Left e → fail $ "Duplicate extension: " ⊕ show e + where + pairs ∷ Parser [(MIMEType, [Text])] + pairs = do skipMany linebreak + xs ← sepBy pair (skipMany1 linebreak) + skipMany linebreak + endOfInput + return xs + + "pairs" + + pair ∷ Parser (MIMEType, [Text]) + pair = do skipSpace + mime ← def + skipSpace1 + exts ← sepBy1 ext $ skipWhile1 (≡ '\x20') + return (mime, exts) + + "pair" + + ext ∷ Parser Text + ext = (decodeUtf8 <$> takeWhile1 isAlphaNum) + + "ext" + + linebreak ∷ Parser () + linebreak + = ( endOfLine + <|> + try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine) + ) + + "linebreak" + +compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) +compile = go (∅) ∘ concat ∘ (tr <$>) where - records :: [HsExp] - records = map record $ M.assocs extMap - - record :: (String, MIMEType) -> HsExp - record (ext, mime) - = 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 + tr ∷ (v, [k]) → [(k, v)] + tr (v, ks) = [(k, v) | k ← ks] + + go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v) + go m [] = Right m + go m ((k, v):xs) + = case M.insertLookupWithKey' f k v m of + (Nothing, m') → go m' xs + (Just v0, _ ) → Left (k, v0, v) + + f ∷ k → v → v → v + f _ _ = id + +-- |Guess the MIME Type of a file. +guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType +guessTypeByFileName (ExtMap m) fpath + = case takeExtension fpath of + [] → Nothing + (_:ext) → M.lookup (cs ext) m