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=226e01483cb233ecf88be8b0e0871f71678e3058;hb=90fca0675b1694e69b8e431c989343855cbd125d;hpb=3fe5ca3bca04e0124a5f2440e893dc5375e0bb51 diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 226e014..05d0cd6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,143 +1,144 @@ {-# LANGUAGE - BangPatterns + DeriveDataTypeable + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , TemplateHaskell , UnicodeSyntax + , ViewPatterns #-} --- |MIME Type guessing by a file extension. This is a poor man's way --- of guessing MIME Types. It is simple and fast. +-- |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 , guessTypeByFileName - - , parseExtMapFile - , serializeExtMap ) where import Control.Applicative -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 as P -import qualified Data.Attoparsec.Lazy as AL -import qualified Data.ByteString.Lazy.Char8 as B +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 Data.Typeable +import Data.List +import Data.Monoid +import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T import Data.Text.Encoding -import Language.Haskell.Pretty -import Language.Haskell.Syntax +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 --- |'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 +-- |A 'Map' from file extensions to 'MIMEType's. +newtype ExtMap + = ExtMap (Map Text MIMEType) + deriving (Eq, Show, Read, Monoid, Typeable) --- |Read an Apache mime.types and parse it. -parseExtMapFile ∷ FilePath → IO ExtMap -parseExtMapFile fpath - = do file ← B.readFile fpath - case AL.parse extMapP file of - AL.Done _ xs → return $ compile xs - AL.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) +instance Lift ExtMap where + lift (ExtMap m) = [| ExtMap $(lift m) |] -extMapP ∷ Parser [ (MIMEType, [Text]) ] -extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) - endOfInput - return $ catMaybes xs +-- |'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 - isSpc ∷ Char → Bool - isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' + parseExtMap ∷ Lazy.ByteString → ExtMap + parseExtMap = convertUnsafe - comment ∷ Parser (Maybe (MIMEType, [Text])) - comment = try $ - do skipWhile isSpc - _ ← char '#' - skipWhile (≢ '\x0A') - return Nothing + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of extMap quasi-quoter." - validLine ∷ Parser (Maybe (MIMEType, [Text])) - validLine = try $ - do skipWhile isSpc - mime ← mimeTypeP - skipWhile isSpc - exts ← sepBy extP (skipWhile isSpc) - return $ Just (mime, exts) +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" - extP ∷ Parser Text - extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A')) + pair ∷ Parser (MIMEType, [Text]) + pair = do skipSpace + mime ← def + skipSpace1 + exts ← sepBy1 ext $ skipWhile1 (≡ '\x20') + return (mime, exts) + + "pair" - emptyLine ∷ Parser (Maybe (MIMEType, [Text])) - emptyLine = try $ - do skipWhile isSpc - _ ← char '\x0A' - return Nothing + ext ∷ Parser Text + ext = (decodeUtf8 <$> takeWhile1 isAlphaNum) + + "ext" -compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType -compile = M.fromList ∘ concat ∘ map tr - where - tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext ← exts ] + linebreak ∷ Parser () + linebreak + = ( endOfLine + <|> + try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine) + ) + + "linebreak" --- |@'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 (⊥) [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.\n" - ⧺ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" - in - comment ⧺ prettyPrint hsModule ⧺ "\n" +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 + tr ∷ (v, [k]) → [(k, v)] + tr (v, ks) = [(k, v) | k ← ks] - record ∷ (Text, MIMEType) → HsExp - record (ext, mime) - = HsTuple - [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack"))) - (HsLit (HsString (T.unpack ext))) - , mimeToExp mime - ] - - mimeToExp ∷ MIMEType → HsExp - mimeToExp mt - = HsApp (HsVar (UnQual (HsIdent "parseMIMEType"))) - (HsParen - (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString"))) - (HsLit (HsString $ mimeToString mt)))) + 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) - mimeToString ∷ MIMEType → String - mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType + 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