X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=37a3ad6f25a7f1eb1a35da9e74ac7de01d7224b6;hb=72a3e24;hp=3344f4b7351f1d545dc5a908f40457f65ad34cfe;hpb=05f49fae07dfcac0c039f25c8a51123603918a93;p=Lucu.git diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 3344f4b..37a3ad6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - BangPatterns - , UnicodeSyntax + UnicodeSyntax #-} -- |MIME Type guessing by a file extension. This is a poor man's way -- of guessing MIME Types. It is simple and fast. @@ -17,16 +16,19 @@ module Network.HTTP.Lucu.MIMEType.Guess 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.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M import Data.Map (Map) import Data.Maybe +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.Exts.Build +import Language.Haskell.Exts.Extension +import Language.Haskell.Exts.Pretty +import Language.Haskell.Exts.Syntax import Network.HTTP.Lucu.MIMEType import Prelude.Unicode import System.FilePath @@ -36,18 +38,26 @@ 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 +guessTypeByFileName extMap fpath + = case takeExtension fpath of + [] → Nothing + (_:ext) → M.lookup (T.pack ext) extMap -- |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) + case LP.parse extMapP file of + LP.Done _ xs + → case compile xs of + Right m → return m + Left e → fail (concat [ "Duplicate extension \"" + , show e + , "\" in: " + , fpath + ]) + LP.Fail _ _ e + → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) extMapP ∷ Parser [ (MIMEType, [Text]) ] extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) @@ -81,60 +91,67 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) _ ← char '\x0A' return Nothing -compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType -compile = M.fromList ∘ concat ∘ map tr +compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) +compile = go (∅) ∘ concat ∘ map tr where - tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext ← exts ] + 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 -- |@'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 +-- * @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" + = let hsModule = Module (⊥) (ModuleName moduleName) modPragma + Nothing (Just exports) imports decls + modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ] + exports = [ EVar (UnQual (name variableName)) ] + imports = [ ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType") + False False Nothing Nothing Nothing + , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType.Guess") + False False Nothing Nothing Nothing + , ImportDecl (⊥) (ModuleName "Data.Ascii") + False False Nothing Nothing (Just (False, [])) + , ImportDecl (⊥) (ModuleName "Data.Map") + True False Nothing (Just (ModuleName "M")) Nothing + ] + decls = [ TypeSig (⊥) [name variableName] + (TyCon (UnQual (name "ExtMap"))) + , nameBind (⊥) (name variableName) extMapExp + ] + comment = concat [ "{- !!! WARNING !!!\n" + , " This file is automatically generated.\n" + , " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" + ] + extMapExp = qvar (ModuleName "M") (name "fromList") `app` listE records in - comment ++ prettyPrint hsModule ++ "\n" + comment ⧺ prettyPrint hsModule ⧺ "\n" where - records ∷ [HsExp] + records ∷ [Exp] records = map record $ M.assocs extMap - record ∷ (Text, MIMEType) → HsExp + record ∷ (Text, MIMEType) → Exp 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 $ A.toString $ printMIMEType mt)))) + = tuple [ strE (T.unpack ext) + , metaFunction "parseMIMEType" [strE $ mimeToString mime] + ] + + mimeToString ∷ MIMEType → String + mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType