From: PHO Date: Thu, 10 Nov 2011 01:13:44 +0000 (+0900) Subject: ImplantFile started working again. X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=4e41b11200285142757434e9d67e17ed20fae455;p=Lucu.git ImplantFile started working again. Ditz-issue: 123424c3b4a0d83452e26403cd79676f319d4295 --- diff --git a/ImplantFile.hs b/ImplantFile.hs index c253c2a..b6545a8 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,34 +1,22 @@ {-# LANGUAGE - OverloadedStrings - , UnicodeSyntax + UnicodeSyntax #-} -module Main where -import Codec.Compression.GZip +module Main (main) where import Control.Applicative import Control.Monad import qualified Data.Ascii as A -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as Strict -import qualified Data.ByteString.Lazy as Lazy import Data.Char -import Data.Digest.Pure.SHA -import Data.Int import Data.Maybe -import Data.Time -import Data.Time.Clock.POSIX -import Language.Haskell.Exts.Build -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Pretty -import Language.Haskell.Exts.Syntax +import Language.Haskell.TH.PprLib +import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Implant.Input +import Network.HTTP.Lucu.Implant.PrettyPrint import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap -import Network.HTTP.Lucu.MIMEType.Guess import Prelude.Unicode import System.Console.GetOpt import System.Environment import System.Exit -import System.Posix.Files import System.IO data CmdOpt @@ -73,7 +61,7 @@ printUsage = do mapM_ putStrLn msg where msg = [ "" , "Description:" - , concat [ " lucu-implant-file is an utility that generates " + , concat [ " lucu-implant-file is an utility that generates " , "Haskell code containing an arbitrary file to " , "compile it directly into programs and serve it " , "statically with the Lucu HTTP server." @@ -104,291 +92,15 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs generateHaskellSource opts (head sources) -generateHaskellSource ∷ [CmdOpt] → FilePath → IO () -generateHaskellSource opts srcFile - = do modName ← getModuleName opts - symName ← getSymbolName opts modName - mType ← getMIMEType opts srcFile - lastMod ← getLastModified srcFile - input ← openInput srcFile - output ← openOutput opts - tag ← getETag opts input - - let compParams = defaultCompressParams { compressLevel = bestCompression } - gzippedData = compressWith compParams input - originalLen = Lazy.length input - gzippedLen = Lazy.length gzippedData - useGZip = originalLen > gzippedLen - rawB64 = B64.encode <$> Lazy.toChunks input - gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData - - header ← mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod - - let hsModule = mkModule modName symName imports decls - imports = mkImports useGZip - decls = concat [ resourceDecl symName useGZip - , entityTagDecl tag - , lastModifiedDecl lastMod - , contentTypeDecl mType - , if useGZip then - dataDecl (name "gzippedData") gzippedB64 - else - dataDecl (name "rawData") rawB64 - ] - - hPutStrLn output header - hPutStrLn output (prettyPrint hsModule) - hClose output - -mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module -mkModule modName symName imports decls - = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ] - exports = [ EVar (UnQual symName) ] - in - Module (⊥) modName modPragma Nothing (Just exports) imports decls - -mkImports ∷ Bool → [ImportDecl] -mkImports useGZip - = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64") - True False Nothing (Just (ModuleName "B64")) Nothing - , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy") - True False Nothing (Just (ModuleName "Lazy")) Nothing - , ImportDecl (⊥) (ModuleName "Data.Time") - False False Nothing Nothing Nothing - , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu") - False False Nothing Nothing Nothing - ] - ⧺ - [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") - False False Nothing Nothing Nothing - | useGZip ] - -resourceDecl ∷ Name → Bool → [Decl] -resourceDecl symName useGZip - = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef"))) - , nameBind (⊥) symName valExp - ] - where - valExp ∷ Exp - valExp = RecUpdate (function "emptyResource") - [ FieldUpdate (UnQual (name "resGet" )) resGet - , FieldUpdate (UnQual (name "resHead")) resHead - ] - - resGet ∷ Exp - resGet | useGZip = resGetGZipped - | otherwise = resGetRaw - -resHead ∷ Exp -resHead - = function "Just" `app` - paren (doE [ foundEntityStmt - , setContentTypeStmt - ]) - -resGetGZipped ∷ Exp -resGetGZipped - = function "Just" `app` - paren (doE [ foundEntityStmt - , setContentTypeStmt - , bindGZipStmt - , conditionalOutputStmt - ]) - where - condVarName ∷ Name - condVarName = name "gzipAllowed" - - dataVarName ∷ Name - dataVarName = name "gzippedData" - - bindGZipStmt ∷ Stmt - bindGZipStmt - = genStmt (⊥) - (pvar condVarName) - (function "isEncodingAcceptable" `app` strE "gzip") - - conditionalOutputStmt ∷ Stmt - conditionalOutputStmt - = qualStmt $ - If (var condVarName) - (doE [ setContentEncodingGZipStmt - , putChunksStmt (var dataVarName) - ]) - (putChunksExp - (paren - (function "decompress" `app` var dataVarName))) - -resGetRaw ∷ Exp -resGetRaw - = function "Just" `app` - paren (doE [ foundEntityStmt - , setContentTypeStmt - , putChunksStmt (function "rawData") - ]) - -setContentEncodingGZipStmt ∷ Stmt -setContentEncodingGZipStmt - = qualStmt - ( function "setContentEncoding" - `app` - listE [ strE "gzip" ] - ) - -foundEntityStmt ∷ Stmt -foundEntityStmt - = qualStmt $ - metaFunction "foundEntity" - [ var (name "entityTag") - , var (name "lastModified") - ] - -setContentTypeStmt ∷ Stmt -setContentTypeStmt - = qualStmt - ( function "setContentType" - `app` - function "contentType" - ) - -putChunksExp ∷ Exp → Exp -putChunksExp = app (function "putChunks") - -putChunksStmt ∷ Exp → Stmt -putChunksStmt = qualStmt ∘ putChunksExp - -entityTagDecl ∷ ETag → [Decl] -entityTagDecl tag - = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag"))) - , nameBind (⊥) varName valExp - ] - where - varName ∷ Name - varName = name "entityTag" - - valExp ∷ Exp - valExp = function "parseETag" `app` strE (eTagToString tag) - -lastModifiedDecl ∷ UTCTime → [Decl] -lastModifiedDecl lastMod - = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime"))) - , nameBind (⊥) varName valExp - , InlineSig (⊥) False AlwaysActive (UnQual varName) - ] - where - varName ∷ Name - varName = name "lastModified" - - valExp ∷ Exp - valExp = function "read" `app` strE (show lastMod) - -contentTypeDecl ∷ MIMEType → [Decl] -contentTypeDecl mime - = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) - , nameBind (⊥) varName valExp - , InlineSig (⊥) False AlwaysActive (UnQual varName) - ] - where - varName ∷ Name - varName = name "contentType" - - valExp ∷ Exp - valExp = function "parseMIMEType" `app` strE (mimeToString mime) - - mimeToString ∷ MIMEType → String - mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType - -dataDecl ∷ Name → [Strict.ByteString] → [Decl] -dataDecl varName chunks - = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) - , nameBind (⊥) varName valExp - , InlineSig (⊥) False AlwaysActive (UnQual varName) - ] - where - valExp ∷ Exp - valExp = qvar (ModuleName "Lazy") (name "fromChunks") - `app` - listE (chunkToExp <$> chunks) - - chunkToExp ∷ Strict.ByteString → Exp - chunkToExp chunk - = qvar (ModuleName "B64") (name "decodeLenient") - `app` - strE (Strict.unpack chunk) - -mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String -mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod - = do localLastMod ← utcToLocalZonedTime lastMod - return $ concat - [ "{- DO NOT EDIT THIS FILE.\n" - , " This file is automatically generated by the lucu-implant-file program.\n" - , "\n" - , " Source: ", if srcFile ≡ "-" then - "(stdin)" - else - srcFile - , "\n" - , " Original Length: ", show originalLen, " bytes\n" - , if useGZip then - " Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺ - " Compression: gzip\n" - else - " Compression: disabled\n" - , " MIME Type: ", mimeTypeToString mType, "\n" - , " ETag: ", eTagToString tag, "\n" - , " Last Modified: ", show localLastMod, "\n" - , " -}" - ] - -eTagToString ∷ ETag → String -eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag - -mimeTypeToString ∷ MIMEType → String -mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType - -getModuleName ∷ [CmdOpt] → IO ModuleName -getModuleName opts - = case modNameOpts of - [] → fail "a module name must be given." - OptModName modName:[] → return $ ModuleName modName - _ → fail "too many --module options." - where - modNameOpts ∷ [CmdOpt] - modNameOpts = filter (\ x → case x of - OptModName _ → True - _ → False) opts - -getSymbolName ∷ [CmdOpt] → ModuleName → IO Name -getSymbolName opts (ModuleName modName) - = case symNameOpts of - [] → return defaultSymName - OptSymName symName:[] → return $ name symName - _ → fail "too many --symbol options." - where - symNameOpts ∷ [CmdOpt] - symNameOpts = filter (\ x → case x of - OptSymName _ → True - _ → False) opts - - defaultSymName ∷ Name - defaultSymName - = name $ headToLower $ getLastComp modName - - headToLower ∷ String → String - headToLower [] = error "module name must not be empty" - headToLower (x:xs) = toLower x : xs - - getLastComp ∷ String → String - getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse - -getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType -getMIMEType opts srcFile +getMIMEType ∷ [CmdOpt] → Maybe MIMEType +getMIMEType opts = case mimeTypeOpts of - [] → return defaultType + [] → Nothing OptMIMEType ty:[] → case A.fromChars ty of - Just a → return $ parseMIMEType a - Nothing → fail "MIME type must not contain any non-ASCII letters." - _ → fail "too many --mime-type options." + Just a → Just $ parseMIMEType a + Nothing → error "MIME types must not contain any non-ASCII letters." + _ → error "too many --mime-type options." where mimeTypeOpts ∷ [CmdOpt] mimeTypeOpts @@ -396,50 +108,31 @@ getMIMEType opts srcFile OptMIMEType _ → True _ → False) opts - octetStream ∷ MIMEType - octetStream = parseMIMEType "application/octet-stream" - - defaultType ∷ MIMEType - defaultType = fromMaybe octetStream - $ guessTypeByFileName defaultExtensionMap srcFile - -getLastModified ∷ FilePath → IO UTCTime -getLastModified "-" = getCurrentTime -getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime) - <$> - getFileStatus fpath - -getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag -getETag opts input +getETag ∷ [CmdOpt] → Maybe ETag +getETag opts = case eTagOpts of - [] → return mkETagFromInput - OptETag str:[] → return $ strToETag str - _ → fail "too many --etag options." + [] → Nothing + OptETag str:[] → Just $ strToETag str + _ → error "too many --etag options." where eTagOpts ∷ [CmdOpt] eTagOpts = filter (\ x → case x of OptETag _ → True _ → False) opts - mkETagFromInput ∷ ETag - mkETagFromInput - = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input) - strToETag ∷ String → ETag strToETag str = case A.fromChars str of Just a → strongETag a Nothing → error "ETag must not contain any non-ASCII letters." -openInput ∷ FilePath → IO Lazy.ByteString -openInput "-" = Lazy.getContents -openInput fpath = Lazy.readFile fpath - openOutput ∷ [CmdOpt] → IO Handle openOutput opts = case outputOpts of [] → return stdout - OptOutput fpath:[] → openFile fpath WriteMode + OptOutput fpath:[] → do h ← openFile fpath WriteMode + hSetEncoding h utf8 + return h _ → fail "two many --output options." where outputOpts ∷ [CmdOpt] @@ -447,96 +140,51 @@ openOutput opts OptOutput _ → True _ → False) opts -{- - 作られるファイルの例 (壓縮されない場合): - ------------------------------------------------------------------------------ - {- DO NOT EDIT THIS FILE. - This file is automatically generated by the lucu-implant-file program. - - Source: baz.png - Original Length: 302 bytes - Compressed Length: 453 bytes -- これは Compression: disabled の時には無い - Compression: disabled - MIME Type: image/png - ETag: "d41d8cd98f00b204e9800998ecf8427e" - Last Modified: 2007-11-05 13:53:42.231882 JST - -} - {-# LANGUAGE OverloadedStrings #-} - module Foo.Bar.Baz (baz) where - import qualified Data.ByteString.Base64 as B64 - import qualified Data.ByteString.Lazy as Lazy - import Data.Time - import Network.HTTP.Lucu - - baz ∷ ResourceDef - baz = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do foundEntity entityTag lastModified - setContentType contentType - putChunk rawData - , resHead - = Just $ do foundEntity entityTag lastModified - setContentType contentType - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } - - entityTag ∷ ETag - entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" - - lastModified ∷ UTCTime - {-# NOINLINE lastModified #-} - lastModified = read "2007-11-05 04:47:56.008366 UTC" - - contentType ∷ MIMEType - {-# NOINLINE contentType #-} - contentType = parseMIMEType "image/png" +getModuleName ∷ [CmdOpt] → ModName +getModuleName opts + = case modNameOpts of + [] → error "a module name must be given." + OptModName name:[] → mkModName name + _ → error "too many --module options." + where + modNameOpts ∷ [CmdOpt] + modNameOpts = filter (\ x → case x of + OptModName _ → True + _ → False) opts - rawData ∷ Lazy.ByteString - {-# NOINLINE rawData #-} - rawData = Lazy.fromChunks - [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..." - , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..." - ] - ------------------------------------------------------------------------------ +getSymbolName ∷ [CmdOpt] → Maybe Name +getSymbolName opts + = case symNameOpts of + [] → Nothing + OptSymName name:[] → Just $ mkName name + _ → fail "too many --symbol options." + where + symNameOpts ∷ [CmdOpt] + symNameOpts = filter (\ x → case x of + OptSymName _ → True + _ → False) opts - 壓縮される場合は次のやうに變はる: - ------------------------------------------------------------------------------ - -- import に追加 - import Codec.Compression.Zlib +defaultSymName ∷ ModName → Name +defaultSymName = headToLower ∘ getLastComp + where + headToLower ∷ String → Name + headToLower [] = error "module name must not be empty" + headToLower (x:xs) = mkName (toLower x:xs) - -- ResourceDef は次のやうに變化 - baz ∷ ResourceDef - baz = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do foundEntity entityTag lastModified - setContentType contentType + getLastComp ∷ ModName → String + getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString - gzipAllowed ← isEncodingAcceptable "gzip" - if gzipAllowed then - do setContentEncoding ["gzip"] - putChunks gzippedData - else - putChunks (decompress gzippedData) - , resHead - = Just $ do foundEntity entityTag lastModified - setContentType contentType - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } +generateHaskellSource ∷ [CmdOpt] → FilePath → IO () +generateHaskellSource opts srcFile + = do i ← openInput srcFile (getMIMEType opts) (getETag opts) + o ← openOutput opts + doc ← pprInput i modName symName + hPutStrLn o $ show $ to_HPJ_Doc doc + hClose o + where + modName ∷ ModName + modName = getModuleName opts - -- rawData の代はりに gzippedData - gzippedData ∷ Lazy.ByteString - {-# NOINLINE gzippedData #-} - gzippedData = Lazy.fromChunks - [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." - , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..." - ] - ------------------------------------------------------------------------------ - -} + symName ∷ Name + symName = fromMaybe (defaultSymName modName) + $ getSymbolName opts diff --git a/Lucu.cabal b/Lucu.cabal index deed597..7ceb6c2 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -117,10 +117,15 @@ Executable lucu-implant-file Main-Is: ImplantFile.hs + Other-Modules: + Network.HTTP.Lucu.Implant.Input + Network.HTTP.Lucu.Implant.PrettyPrint + Network.HTTP.Lucu.Implant.Rewrite + Build-Depends: - SHA == 1.5.*, - haskell-src-exts == 1.11.*, - zlib == 0.5.* + SHA == 1.5.*, + syb == 0.3.*, + zlib == 0.5.* ghc-options: -Wall diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index d871000..b8191a3 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -1,5 +1,8 @@ {-# LANGUAGE - OverloadedStrings + DeriveDataTypeable + , OverloadedStrings + , RecordWildCards + , TemplateHaskell , UnicodeSyntax #-} -- |Entity tags @@ -19,7 +22,9 @@ import Control.Monad import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 +import Data.Data import Data.Monoid.Unicode +import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http hiding (token) import Network.HTTP.Lucu.Utils @@ -34,7 +39,15 @@ data ETag = ETag { -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~) -- are allowed. , etagToken ∷ !Ascii - } deriving (Eq, Show) + } deriving (Eq, Show, Data, Typeable) + +instance Lift ETag where + lift (ETag {..}) + = [| ETag { + etagIsWeak = $(lift etagIsWeak) + , etagToken = $(liftAscii etagToken) + } + |] -- |Convert an 'ETag' to an 'AsciiBuilder'. printETag ∷ ETag → AsciiBuilder diff --git a/Network/HTTP/Lucu/Implant/Input.hs b/Network/HTTP/Lucu/Implant/Input.hs new file mode 100644 index 0000000..4b462e3 --- /dev/null +++ b/Network/HTTP/Lucu/Implant/Input.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE + QuasiQuotes + , RecordWildCards + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Implant.Input + ( Input(..) + + , originalLen + , gzippedLen + , useGZip + + , openInput + ) + where +import Codec.Compression.GZip +import Control.Applicative +import qualified Data.Ascii as A +import qualified Data.ByteString.Lazy as L +import Data.Digest.Pure.SHA +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX +import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.MIMEType hiding (mimeType) +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.MIMEType.TH +import Prelude.Unicode +import System.Posix.Files + +data Input + = Input { + iPath ∷ !FilePath + , iLastMod ∷ !UTCTime + , iType ∷ !MIMEType + , iETag ∷ !ETag + , iRawData ∷ !L.ByteString + , iGZipped ∷ !L.ByteString + } + +originalLen ∷ Input → Integer +originalLen (Input {..}) + = fromIntegral $ L.length iRawData + +gzippedLen ∷ Input → Integer +gzippedLen (Input {..}) + = fromIntegral $ L.length iGZipped + +useGZip ∷ Input → Bool +useGZip i + = originalLen i ≥ gzippedLen i + +openInput ∷ FilePath → Maybe MIMEType → Maybe ETag → IO Input +openInput fpath ctype etag + = do lastMod ← lastModified fpath + input ← openInputFile fpath + return Input { + iPath = fpath + , iLastMod = lastMod + , iType = fromMaybe octetStream + $ ctype <|> guessType fpath + , iETag = fromMaybe (mkETagFromInput input) etag + , iRawData = input + , iGZipped = compressWith compParams input + } + where + octetStream ∷ MIMEType + octetStream = [mimeType| application/octet-stream |] + + compParams ∷ CompressParams + compParams = defaultCompressParams { + compressLevel = bestCompression + } + +lastModified ∷ FilePath → IO UTCTime +lastModified "-" = getCurrentTime +lastModified fpath = ( posixSecondsToUTCTime + ∘ fromRational + ∘ toRational + ∘ modificationTime + ) + <$> + getFileStatus fpath + +openInputFile ∷ FilePath → IO L.ByteString +openInputFile "-" = L.getContents +openInputFile fpath = L.readFile fpath + +guessType ∷ FilePath → Maybe MIMEType +guessType = guessTypeByFileName defaultExtensionMap + +mkETagFromInput ∷ L.ByteString → ETag +mkETagFromInput input + = strongETag $ A.unsafeFromString + $ "SHA-1:" ⧺ showDigest (sha1 input) diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs new file mode 100644 index 0000000..027003d --- /dev/null +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , TemplateHaskell + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Implant.PrettyPrint + ( pprInput + ) + where +import Codec.Compression.GZip +import Control.Monad +import Data.Ascii (CIAscii) +import qualified Data.Ascii as A +import qualified Data.ByteString.Lazy as L +import Data.List +import qualified Data.Map as M +import Data.Time +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.PprLib +import Language.Haskell.TH.Syntax +import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Implant.Input +import Network.HTTP.Lucu.Implant.Rewrite +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Utils +import Prelude.Unicode + +header ∷ Input → Doc +header i@(Input {..}) + = vcat [ text "{- DO NOT EDIT THIS FILE." + , nest 3 $ + vcat [ text "This file is automatically generated by lucu-implant-file." + , text "" + , text " Source:" <+> if iPath ≡ "-" then + text "(stdin)" + else + text iPath + , hsep [ text " Original Length:" + , integer (originalLen i) + , text "bytes" + ] + , if useGZip i then + vcat [ hsep [ text "Compressed Length:" + , integer (gzippedLen i) + , text "bytes" + ] + , text " Compression: gzip" + ] + else + text " Compression: disabled" + , text " MIME Type:" <+> mimeTypeToDoc iType + , text " ETag:" <+> eTagToDoc iETag + , text " Last Modified:" <+> text (show iLastMod) + ] + , text " -}" + , text "{-# LANGUAGE MagicHash #-}" + ] + where + eTagToDoc ∷ ETag → Doc + eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag + + mimeTypeToDoc ∷ MIMEType → Doc + mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType + +moduleDecl ∷ ModName → Name → Doc +moduleDecl modName symName + = hsep [ text "module" + , text (modString modName) + , lparen + , ppr symName + , rparen + , text "where" + ] + +importDecls ∷ ModMap → Doc +importDecls = vcat ∘ map f ∘ M.toAscList + where + f ∷ (ModName, Maybe ModName) → Doc + f (m, Nothing) = hsep [ text "import" + , text (modString m) + ] + f (m, Just m') = hsep [ text "import" + , text "qualified" + , text (modString m) + , text "as" + , text (modString m') + ] + +entityTag ∷ Name +entityTag = mkName "entityTag" + +lastModified ∷ Name +lastModified = mkName "lastModified" + +contentType ∷ Name +contentType = mkName "contentType" + +rawData ∷ Name +rawData = mkName "rawData" + +gzippedData ∷ Name +gzippedData = mkName "gzippedData" + +gzipEncoding ∷ Name +gzipEncoding = mkName "gzipEncoding" + +resourceDecl ∷ Input → Name → Q [Dec] +resourceDecl i symName + = sequence [ sigD symName [t| ResourceDef |] + , valD (varP symName) (normalB (resourceE i)) decls + ] + where + decls ∷ [Q Dec] + decls | useGZip i + = [ sigD gzipEncoding [t| CIAscii |] + , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) [] + ] + | otherwise + = [] + +resourceE ∷ Input → Q Exp +resourceE i = [| emptyResource { + resGet = $(resGetE i) + , resHead = $(resHeadE i) + } + |] + +resGetE ∷ Input → Q Exp +resGetE i + | useGZip i + = [| Just $ + do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) + + gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding) + if gzipAllowed then + do setContentEncoding [$(varE gzipEncoding)] + putChunks $(varE gzippedData) + else + putChunks (decompress $(varE gzippedData)) + |] + | otherwise + = [| Just $ + do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) + putChunks $(varE rawData) + |] + +resHeadE ∷ Input → Q Exp +resHeadE i + | useGZip i + = [| Just $ + do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) + + gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding) + when gzipAllowed (setContentEncoding [$(varE gzipEncoding)]) + |] + | otherwise + = [| Just $ + do foundEntity $(varE entityTag) + $(varE lastModified) + setContentType $(varE contentType) + |] + +eTagDecl ∷ Input → Q [Dec] +eTagDecl (Input {..}) + = sequence [ sigD entityTag [t| ETag |] + , valD (varP entityTag) (normalB (lift iETag)) [] + ] + +lastModDecl ∷ Input → Q [Dec] +lastModDecl (Input {..}) + = sequence [ sigD lastModified [t| UTCTime |] + , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) [] + ] + +contTypeDecl ∷ Input → Q [Dec] +contTypeDecl (Input {..}) + = sequence [ sigD contentType [t| MIMEType |] + , valD (varP contentType) (normalB (lift iType)) [] + ] + +binDecl ∷ Input → Q [Dec] +binDecl i@(Input {..}) + | useGZip i + = sequence [ sigD gzippedData [t| L.ByteString |] + , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) [] + ] + | otherwise + = sequence [ sigD rawData [t| L.ByteString |] + , valD (varP rawData) (normalB (liftLazyByteString iRawData)) [] + ] + +pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc +pprInput i modName symName + = do decls ← runQ $ sequence [ resourceDecl i symName + , eTagDecl i + , lastModDecl i + , contTypeDecl i + , binDecl i + ] + let (decls', mods) = rewriteNames decls + return $ vcat [ header i + , moduleDecl modName symName + , importDecls mods + , text "" + , vcat $ intersperse (text "") $ map ppr decls' + ] diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs new file mode 100644 index 0000000..37fbfbb --- /dev/null +++ b/Network/HTTP/Lucu/Implant/Rewrite.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE + UnicodeSyntax + #-} +module Network.HTTP.Lucu.Implant.Rewrite + ( ModMap + , rewriteNames + ) + where +import Control.Applicative +import Control.Monad.State +import Data.Data +import Data.Generics.Aliases +import Data.Generics.Schemes +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid.Unicode +import Language.Haskell.TH.Syntax +import Prelude.Unicode + +-- FIXME: Document at least these data types. +type ModMap = Map ModName (Maybe ModName) +data RewriteTo = Qual (Maybe ModName) ModName | UnQual (Maybe ModName) + +rewriteNames ∷ Data d ⇒ d → (d, ModMap) +rewriteNames + = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName)) + +rewriteName ∷ (Functor m, Monad m) + ⇒ Name + → StateT ModMap m Name +rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl + +rewriteNameFlavour ∷ (Functor m, Monad m) + ⇒ NameFlavour + → StateT ModMap m NameFlavour +rewriteNameFlavour fl + = case getModName fl of + Nothing → return fl + Just m → do let r = M.lookup m modules + insertIntoModMap m r + return $ setModName r fl + +insertIntoModMap ∷ Monad m + ⇒ ModName + → Maybe RewriteTo + → StateT ModMap m () +insertIntoModMap _ (Just (Qual (Just m) m')) = modify $ M.insert m (Just m') +insertIntoModMap m (Just (Qual Nothing m')) = modify $ M.insert m (Just m') +insertIntoModMap _ (Just (UnQual (Just m) )) = modify $ M.insert m Nothing +insertIntoModMap _ (Just (UnQual Nothing )) = return () +insertIntoModMap m Nothing = modify $ M.insert m Nothing + +getModName ∷ NameFlavour → Maybe ModName +getModName (NameQ m) = Just m +getModName (NameG _ _ m) = Just m +getModName _ = Nothing + +setModName ∷ Maybe RewriteTo → NameFlavour → NameFlavour +setModName (Just (Qual _ m)) (NameQ _ ) = NameQ m +setModName (Just (Qual _ m)) (NameG _ _ _) = NameQ m +setModName (Just (UnQual _)) (NameQ _ ) = NameS +setModName (Just (UnQual _)) (NameG _ _ _) = NameS +setModName Nothing (NameQ _ ) = NameS +setModName Nothing (NameG _ _ _) = NameS +setModName _ _ = error "setModName: internal error" + +modules ∷ Map ModName RewriteTo +modules + = M.fromList + [ ( mkModName "Codec.Compression.GZip" + , Qual Nothing $ mkModName "G" + ) + , ( mkModName "Data.Ascii" + , Qual Nothing $ mkModName "A" + ) + , ( mkModName "Data.ByteString.Char8" + , Qual Nothing $ mkModName "B" + ) + , ( mkModName "Data.ByteString.Lazy.Internal" + , Qual Nothing $ mkModName "L" + ) + , ( mkModName "Data.ByteString.Unsafe" + , Qual Nothing $ mkModName "B" + ) + , ( mkModName "Data.Map" + , Qual Nothing $ mkModName "M" + ) + , ( mkModName "Data.Maybe" + , UnQual Nothing + ) + , ( mkModName "Data.Text" + , Qual Nothing $ mkModName "T" + ) + , ( mkModName "Data.Time.Calendar.Days" + , UnQual $ Just $ mkModName "Data.Time" + ) + , ( mkModName "Data.Time.Clock.Scale" + , UnQual $ Just $ mkModName "Data.Time" + ) + , ( mkModName "Data.Time.Clock.UTC" + , UnQual $ Just $ mkModName "Data.Time" + ) + , ( mkModName "GHC.Base" + , UnQual Nothing + ) + , ( mkModName "GHC.Bool" + , UnQual Nothing + ) + , ( mkModName "GHC.IO" + -- for 'unsafePerformIO', but rather problematic... + , UnQual $ Just $ mkModName "System.IO.Unsafe" + ) + , ( mkModName "GHC.Real" + -- for '%', but rather problematic... + , UnQual $ Just $ mkModName "Data.Ratio" + ) + , ( mkModName "Network.HTTP.Lucu.ETag" + , UnQual $ Just $ mkModName "Network.HTTP.Lucu" + ) + , ( mkModName "Network.HTTP.Lucu.MIMEType" + , UnQual $ Just $ mkModName "Network.HTTP.Lucu" + ) + , ( mkModName "Network.HTTP.Lucu.Resource" + , UnQual $ Just $ mkModName "Network.HTTP.Lucu" + ) + , ( mkModName "Network.HTTP.Lucu.Resource.Internal" + , UnQual $ Just $ mkModName "Network.HTTP.Lucu" + ) + ] diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index df5e230..abc1cf5 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -147,6 +147,7 @@ data NormalInteraction , niWillDiscardBody ∷ !(TVar Bool) , niWillClose ∷ !(TVar Bool) , niResponseHasCType ∷ !(TVar Bool) + -- FIXME: use TBChan Builder (in stm-chans package) , niBodyToSend ∷ !(TMVar Builder) , niState ∷ !(TVar InteractionState) @@ -216,6 +217,7 @@ type InteractionQueue = TVar (Seq SomeInteraction) mkInteractionQueue ∷ IO InteractionQueue mkInteractionQueue = newTVarIO (∅) +-- FIXME: Response.hs should provide setStatus ∷ sc → Response → Response setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM () setResponseStatus (NI {..}) sc = do res ← readTVar niResponse diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 90cdcb0..ffda4cf 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -66,6 +66,7 @@ handleStaticFile sendContent path $ abort $ mkAbortion Forbidden [] Nothing + -- FIXME: Forget about ETags of a static file. tag ← liftIO $ generateETagFromFile path let lastMod = posixSecondsToUTCTime $ fromRational diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index d6e571d..55acf0a 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings + , RecordWildCards , TemplateHaskell , UnicodeSyntax #-} @@ -11,28 +12,37 @@ module Network.HTTP.Lucu.Utils , parseWWWFormURLEncoded , splitPathInfo , trim + , liftByteString + , liftLazyByteString + , liftAscii , liftCIAscii , liftText , liftMap + , liftUTCTime ) where import Control.Monad import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as Strict +import qualified Data.ByteString.Unsafe as Strict +import qualified Data.ByteString.Lazy.Internal as Lazy import Data.Char import Data.List hiding (last) import Data.Map (Map) import qualified Data.Map as M import Data.Monoid.Unicode +import Data.Ratio import Data.Text (Text) import qualified Data.Text as T +import Data.Time import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax import Network.URI import Prelude hiding (last) import Prelude.Unicode +import System.IO.Unsafe -- |>>> splitBy (== ':') "ab:c:def" -- ["ab", "c", "def"] @@ -53,15 +63,17 @@ quoteStr str = A.toAsciiBuilder "\"" ⊕ go (A.toByteString str) (∅) ⊕ A.toAsciiBuilder "\"" where - go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder + go ∷ Strict.ByteString → AsciiBuilder → AsciiBuilder go bs ab - = case BS.break (≡ '"') bs of + = case Strict.break (≡ '"') bs of (x, y) - | BS.null y → ab ⊕ b2ab x - | otherwise → go (BS.tail y) (ab ⊕ b2ab x - ⊕ A.toAsciiBuilder "\\\"") + | Strict.null y + → ab ⊕ b2ab x + | otherwise + → go (Strict.tail y) + (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"") - b2ab ∷ BS.ByteString → AsciiBuilder + b2ab ∷ Strict.ByteString → AsciiBuilder b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" @@ -80,7 +92,7 @@ parseWWWFormURLEncoded src ) where unescape ∷ String → ByteString - unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace + unescape = Strict.pack ∘ unEscapeString ∘ map plusToSpace plusToSpace ∷ Char → Char plusToSpace '+' = ' ' @@ -93,7 +105,7 @@ splitPathInfo uri = let reqPathStr = uriPath uri reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] in - map BS.pack reqPath + map Strict.pack reqPath -- |>>> trim " ab c d " -- "ab c d" @@ -102,24 +114,70 @@ trim = reverse ∘ f ∘ reverse ∘ f where f = dropWhile isSpace +-- |Convert a 'ByteString' to an 'Exp' representing it as a literal. +liftByteString ∷ ByteString → Q Exp +liftByteString bs + = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |] + +-- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a +-- literal. +liftLazyByteString ∷ Lazy.ByteString → Q Exp +liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |] + where + f ∷ ByteString → Q Exp → Q Exp + f bs e = [| Lazy.Chunk $(liftByteString bs) $e |] + +-- |Convert an 'Ascii' to an 'Exp' representing it as a literal. +liftAscii ∷ Ascii → Q Exp +liftAscii a = [| A.unsafeFromByteString + $ unsafePerformIO + $ Strict.unsafePackAddressLen $len $ptr + |] + where + bs ∷ Strict.ByteString + bs = A.toByteString a + + len, ptr ∷ Q Exp + len = lift $ Strict.length bs + ptr = litE $ stringPrimL $ Strict.unpack bs + -- |Convert a 'CIAscii' to an 'Exp' representing it as a literal. liftCIAscii ∷ CIAscii → Q Exp -liftCIAscii a = [| A.toCIAscii (A.unsafeFromString $(strLit a)) |] - where - strLit ∷ CIAscii → Q Exp - strLit = liftString ∘ A.toString ∘ A.fromCIAscii +liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |] -- |Convert a 'Text' to an 'Exp' representing it as a literal. liftText ∷ Text → Q Exp -liftText t = [| T.pack $(strLit t) |] - where - strLit ∷ Text → Q Exp - strLit = liftString ∘ T.unpack +liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |] -- |Convert an arbitrary 'Map' to an 'Exp' representing it as a -- literal, using a given key lifter and a value lifter. liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp -liftMap liftK liftV m = [| M.fromAscList $(liftPairs $ M.toAscList m) |] +liftMap liftK liftV m + | M.null m = [| M.empty |] + | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |] where liftPairs = listE ∘ map liftPair liftPair (k, v) = tupE [liftK k, liftV v] + +-- |Convert an 'UTCTime' to an 'Exp' representing it as a literal. +liftUTCTime ∷ UTCTime → Q Exp +liftUTCTime (UTCTime {..}) + = [| UTCTime { + utctDay = $(liftDay utctDay) + , utctDayTime = $(liftDiffTime utctDayTime) + } + |] + +liftDay ∷ Day → Q Exp +liftDay (ModifiedJulianDay {..}) + = [| ModifiedJulianDay { + toModifiedJulianDay = $(lift toModifiedJulianDay) + } + |] + +liftDiffTime ∷ DiffTime → Q Exp +liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |] + where + n, d ∷ Q Exp + n = lift $ numerator $ toRational dt + d = lift $ denominator $ toRational dt