From 48bc90d66a45c0b9b6f52272b46cf2949ed802e3 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 5 Nov 2011 13:45:38 +0900 Subject: [PATCH] DefaultExtensionMap is now generated with TH. Ditz-issue: c566a8433e8af700655680f53e99cfe9f563ed32 --- .gitignore | 4 - GNUmakefile | 3 - Lucu.cabal | 20 +-- Network/HTTP/Lucu/MIMEParams.hs | 2 +- Network/HTTP/Lucu/MIMEType.hs | 2 +- .../HTTP/Lucu/MIMEType/DefaultExtensionMap.hs | 101 +++++++----- Network/HTTP/Lucu/MIMEType/Guess.hs | 150 ++++++++---------- data/CompileMimeTypes.hs | 21 --- data/Makefile | 18 --- 9 files changed, 130 insertions(+), 191 deletions(-) rename data/mime.types => Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs (68%) delete mode 100755 data/CompileMimeTypes.hs delete mode 100644 data/Makefile diff --git a/.gitignore b/.gitignore index 00bc286..0b4ee08 100644 --- a/.gitignore +++ b/.gitignore @@ -8,10 +8,6 @@ Setup dist report.html -Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs - -data/CompileMimeTypes - examples/HelloWorld examples/Implanted examples/ImplantedSmall diff --git a/GNUmakefile b/GNUmakefile index 3b5520e..1f0eaf7 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -3,6 +3,3 @@ RUN_COMMAND = $(MAKE) -C examples run CONFIGURE_ARGS = -O include cabal-package.mk - -build-hook: - $(MAKE) -C data diff --git a/Lucu.cabal b/Lucu.cabal index 48c9268..8a04bd4 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -22,11 +22,7 @@ Tested-With: GHC == 7.0.3 Cabal-Version: >= 1.6 Build-Type: Simple Extra-Source-Files: - ImplantFile.hs NEWS - data/CompileMimeTypes.hs - data/Makefile - data/mime.types examples/HelloWorld.hs examples/Implanted.hs examples/ImplantedSmall.hs @@ -58,7 +54,6 @@ Library containers == 0.4.*, containers-unicode-symbols == 0.3.*, filepath == 1.2.*, - haskell-src-exts == 1.11.*, hxt == 9.1.*, mtl == 2.0.*, network == 2.3.*, @@ -121,18 +116,9 @@ Executable lucu-implant-file Main-Is: ImplantFile.hs Build-Depends: - SHA == 1.5.*, - zlib == 0.5.* + SHA == 1.5.*, + haskell-src-exts == 1.11.*, + zlib == 0.5.* ghc-options: -Wall - ---Executable HelloWorld --- Main-Is: HelloWorld.hs --- Hs-Source-Dirs: ., examples --- ghc-options: -fglasgow-exts -Wall -funbox-strict-fields -O3 -prof -auto-all - ---Executable Multipart --- Main-Is: Multipart.hs --- Hs-Source-Dirs: ., examples --- ghc-options: -XBangPatterns -fglasgow-exts -Wall -funbox-strict-fields -prof -auto-all diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index b3edeb5..bfde1c9 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -45,7 +45,7 @@ import Network.HTTP.Lucu.Utils import Prelude hiding (concat, mapM, takeWhile) import Prelude.Unicode --- |A map from MIME parameter attributes to values. Attributes are +-- |A 'Map' from MIME parameter attributes to values. Attributes are -- always case-insensitive according to RFC 2045 -- (). newtype MIMEParams diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index d60b70e..88bd5e7 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -65,7 +65,7 @@ parseMIMEType ∷ Ascii → MIMEType parseMIMEType str = case parseOnly (finishOff mimeType) $ A.toByteString str of Right t → t - Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) + Left err → error ("Unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) -- |'Parser' for an 'MIMEType'. mimeType ∷ Parser MIMEType diff --git a/data/mime.types b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs similarity index 68% rename from data/mime.types rename to Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs index 7b7601b..c471da3 100644 --- a/data/mime.types +++ b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs @@ -1,3 +1,19 @@ +{-# LANGUAGE + QuasiQuotes + , UnicodeSyntax + #-} +-- |The default extension map. +module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap + ( defaultExtensionMap + ) + where +import Network.HTTP.Lucu.MIMEType.Guess + +-- |'defaultExtensionMap' contains contains every possible pairs of an +-- extension and a MIME Type. +defaultExtensionMap :: ExtMap +{-# NOINLINE defaultExtensionMap #-} +defaultExtensionMap = [extMap| # MIME type Extensions application/andrew-inset ez application/atom+xml atom @@ -23,33 +39,33 @@ application/vnd.wap.wbxml wbxml application/vnd.wap.wmlc wmlc application/vnd.wap.wmlscriptc wmlsc application/voicexml+xml vxml -application/x-3gp 3gp -application/x-ape ape -application/x-ar a +application/x-3gp 3gp +application/x-ape ape +application/x-ar a application/x-bcpio bcpio -application/x-bzip bz2 tbz +application/x-bzip bz2 tbz application/x-cdlink vcd application/x-chess-pgn pgn -application/x-compress Z +application/x-compress Z application/x-cpio cpio application/x-csh csh application/x-director dcr dir dxr application/x-dvi dvi application/x-futuresplash spl application/x-gtar gtar -application/x-gzip gz tgz +application/x-gzip gz tgz application/x-hdf hdf application/x-javascript js application/x-java-jnlp-file jnlp application/x-koan skp skd skt skm application/x-latex latex -application/x-nar nar +application/x-nar nar application/x-netcdf nc cdf -application/x-rar rar +application/x-rar rar application/x-sh sh application/x-shar shar application/x-shockwave-flash swf swfl -application/x-spc spc +application/x-spc spc application/x-stuffit sit application/x-sv4cpio sv4cpio application/x-sv4crc sv4crc @@ -69,30 +85,30 @@ application/xml xml xsl application/xml-dtd dtd application/zip zip audio/basic au snd -audio/iLBC-sh ilbc +audio/iLBC-sh ilbc audio/midi mid midi kar audio/mp4a-latm m4a m4p audio/mpeg mpga mp2 mp3 -audio/x-ac3 ac3 +audio/x-ac3 ac3 audio/x-aiff aif aiff aifc -audio/x-ircam sf -audio/x-flac flac -audio/x-mod 669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm +audio/x-ircam sf +audio/x-flac flac +audio/x-mod 669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm audio/x-mpegurl m3u -audio/x-musepack mpc -audio/x-nist nist -audio/x-paris paf +audio/x-musepack mpc +audio/x-nist nist +audio/x-paris paf audio/x-pn-realaudio ram ra -audio/x-sds sds -audio/x-shorten shn -audio/x-sid sid -audio/x-svx iff svx -audio/x-ttafile tta -audio/x-voc voc -audio/x-w64 w64 +audio/x-sds sds +audio/x-shorten shn +audio/x-sid sid +audio/x-svx iff svx +audio/x-ttafile tta +audio/x-voc voc +audio/x-w64 w64 audio/x-wav wav -audio/x-wavpack wv wvp -audio/x-wavpack-correction wvc +audio/x-wavpack wv wvp +audio/x-wavpack-correction wvc chemical/x-pdb pdb chemical/x-xyz xyz image/bmp bmp @@ -110,7 +126,7 @@ image/vnd.wap.wbmp wbmp image/x-sun-raster ras image/x-macpaint pntg pnt mac image/x-icon ico -image/x-jng jng +image/x-jng jng image/x-portable-anymap pnm image/x-portable-bitmap pbm image/x-portable-graymap pgm @@ -118,7 +134,7 @@ image/x-portable-pixmap ppm image/x-quicktime qtif qti qif image/x-rgb rgb image/x-xbitmap xbm -image/x-xcf xcf +image/x-xcf xcf image/x-xpixmap xpm image/x-xwindowdump xwd model/iges igs iges @@ -132,28 +148,29 @@ text/richtext rtx text/rtf rtf text/sgml sgml sgm text/tab-separated-values tsv -text/uri-list uni unis uri uris +text/uri-list uni unis uri uris text/vnd.wap.wml wml text/vnd.wap.wmlscript wmls -text/x-c c h -text/x-c++ cc cpp cxx hpp hxx -text/x-cabal cabal -text/x-haskell hs hsc lhs +text/x-c c h +text/x-c++ cc cpp cxx hpp hxx +text/x-cabal cabal +text/x-haskell hs hsc lhs text/x-setext etx video/mp4 mp4 video/mpeg mpeg mpg mpe -video/mpeg4 m4v -video/mpegts ts +video/mpeg4 m4v +video/mpegts ts video/quicktime qt mov video/vnd.mpegurl mxu m4u video/x-dv dv dif -video/x-fli flc fli -video/x-flv flv -video/x-matroska mkv mka -video/x-ms-asf asf wm wma wmv +video/x-fli flc fli +video/x-flv flv +video/x-matroska mkv mka +video/x-ms-asf asf wm wma wmv video/x-msvideo avi -video/x-mng mng -video/x-mve mve -video/x-nuv nuv +video/x-mng mng +video/x-mve mve +video/x-nuv nuv video/x-sgi-movie movie x-conference/x-cooltalk ice +|] diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 10c11e4..8cddcba 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,68 +1,93 @@ {-# LANGUAGE - UnicodeSyntax + 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 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.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.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.Exts.Build -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Pretty -import Language.Haskell.Exts.Syntax +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. -type ExtMap = Map Text MIMEType +newtype ExtMap + = ExtMap (Map Text MIMEType) + deriving (Eq, Show, Read, Monoid, Typeable) --- |Guess the MIME Type of a file. -guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType -guessTypeByFileName em fpath - = case takeExtension fpath of - [] → Nothing - (_:ext) → M.lookup (T.pack ext) em +instance Lift ExtMap where + lift (ExtMap m) + = [| ExtMap $(liftMap liftText lift m) |] --- |Read an Apache mime.types and parse it. -parseExtMapFile ∷ FilePath → IO ExtMap -parseExtMapFile fpath - = do file ← B.readFile fpath - case LP.parse (finishOff extMap) 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) +-- |'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" + + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of extMap quasi-quoter." -extMap ∷ Parser [ (MIMEType, [Text]) ] -extMap = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine) +-- |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, [Text])] +extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine) where isSpc ∷ Char → Bool isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' @@ -104,52 +129,9 @@ compile = go (∅) ∘ concat ∘ map tr 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 the serialised --- @extMap@. --- --- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is --- surely generated using this function. -serializeExtMap ∷ ExtMap → String → String → String -serializeExtMap em moduleName variableName - = 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 - , InlineSig (⊥) False AlwaysActive (UnQual (name variableName)) - ] - 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" - where - records ∷ [Exp] - records = map record $ M.assocs em - - record ∷ (Text, MIMEType) → Exp - record (ext, mime) - = tuple [ strE (T.unpack ext) - , function "parseMIMEType" `app` strE (mimeToString mime) - ] - - mimeToString ∷ MIMEType → String - mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType +-- |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 diff --git a/data/CompileMimeTypes.hs b/data/CompileMimeTypes.hs deleted file mode 100755 index 9ba5b1e..0000000 --- a/data/CompileMimeTypes.hs +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env runghc -{-# LANGUAGE - UnicodeSyntax - #-} -import Network.HTTP.Lucu.MIMEType.Guess -import System - -main ∷ IO () -main = do [inFile, outFile] ← getArgs - extMap ← parseExtMapFile inFile - - let src = serializeExtMap - extMap - "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" - "defaultExtensionMap" - doc = "-- |This module is automatically generated from data\\/mime.types.\n" ++ - "-- 'defaultExtensionMap' contains every possible pairs of an extension\n" ++ - "-- and a MIME Type.\n" ++ - "\n" - - writeFile outFile $ doc ++ src diff --git a/data/Makefile b/data/Makefile deleted file mode 100644 index c73c1f3..0000000 --- a/data/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: dist/DefaultExtensionMap.hs - cp -f $< $@ - -dist/DefaultExtensionMap.hs: mime.types compiler - ./CompileMimeTypes $< $@.tmp - if diff $@ $@.tmp >/dev/null; then \ - rm -f $@.tmp; \ - else \ - mv -f $@.tmp $@; \ - fi - -compiler: - ghc -Wall --make CompileMimeTypes -i.. -odir dist -hidir dist - -clean: - rm -rf dist DefaultExtensionMap.hs CompileMimeTypes - -.PHONY: clean compiler -- 2.40.0