X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=8cddcba19bd60934b934f07dd520c97ef9c7fad9;hp=6f4632609c6b1b2ef0d940de4cdc6b5003f470ef;hb=48bc90d;hpb=11c3854540c46bfcd9e88c2164ed554f3b6550a5 diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 6f46326..8cddcba 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,117 +1,137 @@ --- |MIME Type guesser which guesses by a file extension. This is a --- poor man's way of guessing MIME Types. It is simple and fast. +{-# LANGUAGE + DeriveDataTypeable + , GeneralizedNewtypeDeriving + , 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 + ( ExtMap(..) + , extMap + , parseExtMap , guessTypeByFileName - - , parseExtMapFile - , serializeExtMap ) where - -import qualified Data.ByteString.Lazy.Char8 as B +import Control.Applicative +import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P 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 Data.Typeable +import Data.Monoid +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Utils +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) --- |Map from extension to MIME Type. -type ExtMap = Map String MIMEType +instance Lift ExtMap where + lift (ExtMap m) + = [| ExtMap $(liftMap liftText lift m) |] --- |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 +-- |'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 =≪) ∘ toAscii + , quotePat = const unsupported + , quoteType = const unsupported + , quoteDec = const unsupported + } + where + toAscii ∷ Monad m ⇒ String → m Ascii + toAscii (A.fromChars → Just a) = return a + toAscii _ = fail "Malformed extension map" --- |Read an Apache mime.types and parse it. -parseExtMapFile :: FilePath -> IO ExtMap -parseExtMapFile 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 ++ ")") + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of extMap quasi-quoter." +-- |Parse Apache @mime.types@. +parseExtMap ∷ Ascii → ExtMap +parseExtMap src + = case parseOnly (finishOff extMapP) $ A.toByteString src of + Right xs → case compile xs of + Right m → ExtMap m + Left e → error ("Duplicate extension: " ⧺ show e) + Left err → error ("Unparsable extension map: " ⧺ err) -extMapP :: Parser [ (MIMEType, [String]) ] -extMapP = do xs <- many (comment <|> validLine <|> emptyLine) - eof - return $ catMaybes xs +extMapP ∷ Parser [(MIMEType, [Text])] +extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine) where - spc = oneOf " \t" + isSpc ∷ Char → Bool + isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' - comment = do many spc - char '#' - many $ satisfy (/= '\n') + comment ∷ Parser (Maybe (MIMEType, [Text])) + comment = do skipWhile isSpc + void $ char '#' + skipWhile (≢ '\x0A') return Nothing - validLine = do many spc - mime <- mimeTypeP - many spc - exts <- sepBy token (many spc) + validLine ∷ Parser (Maybe (MIMEType, [Text])) + validLine = do skipWhile isSpc + mime ← mimeType + 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 = do skipWhile isSpc + void $ char '\x0A' + return Nothing -compile :: [ (MIMEType, [String]) ] -> Map String MIMEType -compile = M.fromList . foldr (++) [] . map tr +compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) +compile = go (∅) ∘ concat ∘ map tr where - tr :: (MIMEType, [String]) -> [ (String, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext <- exts ] + tr ∷ (v, [k]) → [(k, v)] + tr (v, ks) = [(k, v) | k ← ks] --- |@'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 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 - ] - 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.\n" - ++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" - in - comment ++ prettyPrint hsModule ++ "\n" - where - records :: [HsExp] - records = map record $ M.assocs extMap + 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 - record :: (String, MIMEType) -> HsExp - record (ext, mime) - = HsTuple [HsLit (HsString ext), mimeToExp mime] - - mimeToExp :: MIMEType -> HsExp - mimeToExp mt - = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt)) +-- |Guess the MIME Type of a file. +guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType +guessTypeByFileName (ExtMap m) fpath + = case takeExtension fpath of + [] → Nothing + (_:ext) → M.lookup (T.pack ext) m