From 1789cee5ee66d2f7f2b26280be2f13eac4df7980 Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 18 Oct 2011 03:53:28 +0900 Subject: [PATCH] Still making many changes... Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- ImplantFile.hs | 150 +++++++++++++++++++++++----- Network/HTTP/Lucu/Abortion.hs | 1 + Network/HTTP/Lucu/DefaultPage.hs | 1 - Network/HTTP/Lucu/MIMEType/Guess.hs | 2 +- Network/HTTP/Lucu/RequestReader.hs | 24 +++-- Network/HTTP/Lucu/Resource.hs | 83 ++++++++------- Network/HTTP/Lucu/Resource/Tree.hs | 12 ++- Network/HTTP/Lucu/ResponseWriter.hs | 37 +++++-- Network/HTTP/Lucu/StaticFile.hs | 2 +- examples/HelloWorld.hs | 1 - 10 files changed, 230 insertions(+), 83 deletions(-) diff --git a/ImplantFile.hs b/ImplantFile.hs index b085a98..67633f7 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -126,15 +126,19 @@ generateHaskellSource opts srcFile let hsModule = mkModule modName symName imports decls imports = mkImports useGZip - decls = concat [ resourceDecl symName useGZip - , entityTagDecl eTag - , lastModifiedDecl lastMod - , contentTypeDecl mimeType - , if useGZip then - dataDecl (name "gzippedData") gzippedB64 - else - dataDecl (name "rawData") rawB64 - ] + decls = concat ([ resourceDecl symName useGZip + , entityTagDecl eTag + , lastModifiedDecl lastMod + , contentTypeDecl mimeType + ] + ⧺ + if useGZip then + [ gunzipAndPutChunkDecl + , dataDecl (name "gzippedData") gzippedB64 + ] + else + [ dataDecl (name "rawData") rawB64 ] + ) hPutStrLn output header hPutStrLn output (prettyPrint hsModule) @@ -159,10 +163,16 @@ mkImports useGZip False False Nothing Nothing Nothing ] ⧺ - [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") - False False Nothing Nothing Nothing - | useGZip - ] + if useGZip then + [ ImportDecl (⊥) (ModuleName "Blaze.ByteString.Builder.ByteString") + True False Nothing (Just (ModuleName "BB")) Nothing + , ImportDecl (⊥) (ModuleName "Codec.Compression.Zlib.Internal") + False False Nothing Nothing Nothing + , ImportDecl (⊥) (ModuleName "Data.Text") + True False Nothing (Just (ModuleName "T")) Nothing + ] + else + [] resourceDecl ∷ Name → Bool → [Decl] resourceDecl symName useGZip @@ -171,7 +181,7 @@ resourceDecl symName useGZip ] where valExp ∷ Exp - valExp = RecUpdate (var $ name "emptyResource") + valExp = RecUpdate (function "emptyResource") [ FieldUpdate (UnQual (name "resGet" )) resGet , FieldUpdate (UnQual (name "resHead")) resHead ] @@ -215,17 +225,14 @@ resGetGZipped (doE [ setContentEncodingGZipStmt , outputStmt (var dataVarName) ]) - ( function "output" - `app` - paren (function "decompress" `app` var dataVarName) - ) + (function "gunzipAndPutChunk" `app` var dataVarName) resGetRaw ∷ Exp resGetRaw = function "Just" `app` paren (doE [ foundEntityStmt , setContentTypeStmt - , outputStmt (var $ name "rawData") + , outputStmt (function "rawData") ]) setContentEncodingGZipStmt ∷ Stmt @@ -240,8 +247,8 @@ foundEntityStmt ∷ Stmt foundEntityStmt = qualStmt $ metaFunction "foundEntity" - [ var $ name "entityTag" - , var $ name "lastModified" + [ var (name "entityTag") + , var (name "lastModified") ] setContentTypeStmt ∷ Stmt @@ -249,12 +256,12 @@ setContentTypeStmt = qualStmt ( function "setContentType" `app` - var (name "contentType") + function "contentType" ) outputStmt ∷ Exp → Stmt outputStmt e - = qualStmt $ function "output" `app` e + = qualStmt $ function "putChunk" `app` e entityTagDecl ∷ ETag → [Decl] entityTagDecl eTag @@ -295,6 +302,84 @@ contentTypeDecl mime mimeToString ∷ MIMEType → String mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType +gunzipAndPutChunkDecl ∷ [Decl] +gunzipAndPutChunkDecl + = [ TypeSig (⊥) [funName] + (TyFun (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) + tyResourceUnit) + , sfun (⊥) funName [] (UnGuardedRhs funExp) (binds goDecl) + ] + where + funName ∷ Name + funName = name "gunzipAndPutChunk" + + goName ∷ Name + goName = name "go" + + tyResourceUnit ∷ Type + tyResourceUnit + = TyApp (TyCon (UnQual (name "Resource"))) + (TyTuple Boxed []) + + funExp ∷ Exp + funExp = var goName + `app` + function "." + `app` + metaFunction "decompressWithErrors" + [ function "gzipFormat" + , function "defaultDecompressParams" + ] + + goDecl ∷ [Decl] + goDecl = [ TypeSig (⊥) [goName] + (TyFun (TyCon (UnQual (name "DecompressStream"))) + tyResourceUnit) + , FunBind [ Match (⊥) goName [pvar (name "StreamEnd")] + Nothing (UnGuardedRhs endExp) (binds []) + , Match (⊥) goName [pApp (name "StreamChunk") + [ pvar (name "x") + , pvar (name "xs") ]] + Nothing (UnGuardedRhs chunkExp) (binds []) + , Match (⊥) goName [pApp (name "StreamError") + [ wildcard + , pvar (name "msg") ]] + Nothing (UnGuardedRhs errorExp) (binds []) + ] + ] + + endExp ∷ Exp + endExp = function "return" `app` tuple [] + + chunkExp ∷ Exp + chunkExp = function "putBuilder" + `app` + paren ( qvar (ModuleName "BB") (name "fromByteString") + `app` + var (name "x") + ) + `app` + function ">>" + `app` + function "go" `app` var (name "xs") + + errorExp ∷ Exp + errorExp = metaFunction "abort" + [ var (name "InternalServerError") + , listE [] + , function "Just" + `app` + paren ( qvar (ModuleName "T") (name "pack") + `app` + paren ( strE "gunzip: " + `app` + function "++" + `app` + var (name "msg") + ) + ) + ] + dataDecl ∷ Name → [Strict.ByteString] → [Decl] dataDecl varName chunks = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) @@ -472,7 +557,7 @@ openOutput opts , resGet = Just $ do foundEntity entityTag lastModified setContentType contentType - output rawData + putChunk rawData , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -500,7 +585,9 @@ openOutput opts 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- import に追加 - import Codec.Compression.GZip + import qualified Blaze.ByteString.Builder.ByteString as BB + import Codec.Compression.Zlib.Internal + import qualified Data.Text as T -- ResourceDef は次のやうに變化 baz ∷ ResourceDef @@ -514,9 +601,9 @@ openOutput opts gzipAllowed ← isEncodingAcceptable "gzip" if gzipAllowed then do setContentEncoding ["gzip"] - output gzippedData + putChunk gzippedData else - output (decompress gzippedData) + gunzipAndPutChunk gzippedData , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -524,6 +611,15 @@ openOutput opts , resPut = Nothing , resDelete = Nothing } + + -- 追加 + gunzipAndPutChunk :: Lazy.ByteString -> Resource () + gunzipAndPutChunk = go . decompressWithErrors gzipFormat defaultDecompressParams + where + go :: DecompressStream -> Resource () + go StreamEnd = return () + go (StreamChunk x xs) = putBuilder (BB.fromByteString x) >> go xs + go (StreamError _ msg) = abort InternalServerError [] (Just (T.pack ("gunzip: " ++ msg))) -- rawData の代はりに gzippedData gzippedData ∷ Lazy.ByteString diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index eeb1c6b..0099576 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -9,6 +9,7 @@ -- in any 'Prelude.IO' monads or arrows. module Network.HTTP.Lucu.Abortion ( Abortion(..) + , abort , abortPurely , abortSTM diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 785e4c1..70d4a6a 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings - , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.DefaultPage diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 37a3ad6..eabc06f 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -150,7 +150,7 @@ serializeExtMap extMap moduleName variableName record ∷ (Text, MIMEType) → Exp record (ext, mime) = tuple [ strE (T.unpack ext) - , metaFunction "parseMIMEType" [strE $ mimeToString mime] + , function "parseMIMEType" `app` strE (mimeToString mime) ] mimeToString ∷ MIMEType → String diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 554fa39..a80ecae 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -56,13 +56,25 @@ requestReader cnf tree fbs h port addr tQueue = do input ← hGetLBS h acceptRequest (Context cnf tree fbs h port addr tQueue) input `catches` - [ Handler $ \ (_ ∷ IOException) → return () - , Handler $ \ e → case e of - ThreadKilled → return () - _ → hPutStrLn stderr (show e) - , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely" - , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e) + [ Handler handleAsyncE + , Handler handleBIOS + , Handler handleOthers ] + where + handleAsyncE ∷ AsyncException → IO () + handleAsyncE ThreadKilled = return () + handleAsyncE e = dump e + + handleBIOS ∷ BlockedIndefinitelyOnSTM → IO () + handleBIOS = dump + + handleOthers ∷ SomeException → IO () + handleOthers = dump + + dump ∷ Exception e ⇒ e → IO () + dump e + = do hPutStrLn stderr "requestReader caught an exception:" + hPutStrLn stderr (show $ toException e) acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO () acceptRequest ctx@(Context {..}) input diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d0454c4..ddff647 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -131,12 +131,13 @@ module Network.HTTP.Lucu.Resource -- |Computation of these actions changes the state to /Deciding -- Body/. - , output - , outputChunk + , putChunk + , putBuilder , driftTo -- private ) where +import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM @@ -410,7 +411,7 @@ getAuthorization return ac -{- ExaminingRequest 時に使用するアクション群 -} +-- Finding an entity -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means @@ -583,7 +584,7 @@ foundNoEntity msgM driftTo GettingBody -{- GettingBody 時に使用するアクション群 -} +-- Getting a request body -- | Computation of @'input' limit@ attempts to read the request body -- up to @limit@ bytes, and then make the 'Resource' transit to @@ -775,7 +776,7 @@ defaultLimit ∷ Int defaultLimit = (-1) -{- DecidingHeader 時に使用するアクション群 -} +-- Setting response headers -- | Set the response status code. If you omit to compute this action, -- the status code will be defaulted to \"200 OK\". @@ -869,48 +870,54 @@ setWWWAuthenticate challenge = setHeader "WWW-Authenticate" (printAuthChallenge challenge) -{- DecidingBody 時に使用するアクション群 -} +-- Writing a response body --- | Write a 'Lazy.ByteString' to the response body, and then transit --- to the /Done/ state. It is safe to apply 'output' to an infinite --- string, such as the lazy stream of \/dev\/random. +-- | Write a chunk in 'Lazy.ByteString' to the response body. It is +-- safe to apply this function to an infinitely long +-- 'Lazy.ByteString'. -- --- Note that you must first set the \"Content-Type\" response header +-- Note that you must first set the response header \"Content-Type\" -- before applying this function. See: 'setContentType' -output ∷ Lazy.ByteString → Resource () -{-# INLINE output #-} -output str = outputChunk str *> driftTo Done +putChunk ∷ Lazy.ByteString → Resource () +{-# INLINE putChunk #-} +putChunk = putBuilder ∘ BB.fromLazyByteString --- | Write a 'Lazy.ByteString' to the response body. This action can --- be repeated as many times as you want. It is safe to apply --- 'outputChunk' to an infinite string. +-- | Run a 'Builder' to construct a chunk, and write it to the +-- response body. It is safe to apply this function to a 'Builder' +-- producing an infinitely long stream of octets. -- --- Note that you must first set the \"Content-Type\" response header +-- Note that you must first set the response header \"Content-Type\" -- before applying this function. See: 'setContentType' -outputChunk ∷ Lazy.ByteString → Resource () -outputChunk str - = do driftTo DecidingBody - itr ← getInteraction +putBuilder ∷ Builder → Resource () +putBuilder b + = do itr ← getInteraction liftIO $ atomically - $ do hasCType ← readTVar $ itrResponseHasCType itr + $ do driftTo' itr DecidingBody + hasCType ← readTVar $ itrResponseHasCType itr unless hasCType $ abortSTM InternalServerError [] - $ Just "outputChunk: Content-Type has not been set." - putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str) + $ Just "putBuilder: Content-Type has not been set." + putTMVar (itrBodyToSend itr) b + + +-- Private driftTo ∷ InteractionState → Resource () driftTo newState = do itr ← getInteraction - liftIO $ atomically - $ do oldState ← readTVar $ itrState itr - if newState < oldState then - throwStateError oldState newState - else - do let a = [oldState .. newState] - b = tail a - c = zip a b - mapM_ (uncurry $ drift itr) c - writeTVar (itrState itr) newState + liftIO $ atomically $ driftTo' itr newState + +driftTo' ∷ Interaction → InteractionState → STM () +driftTo' itr@(Interaction {..}) newState + = do oldState ← readTVar itrState + if newState < oldState then + throwStateError oldState newState + else + do let a = [oldState .. newState] + b = tail a + c = zip a b + mapM_ (uncurry drift) c + writeTVar itrState newState where throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a throwStateError Done DecidingBody @@ -918,10 +925,10 @@ driftTo newState throwStateError old new = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) - drift ∷ Interaction → InteractionState → InteractionState → STM () - drift (Interaction {..}) GettingBody _ + drift ∷ InteractionState → InteractionState → STM () + drift GettingBody _ = writeTVar itrReqBodyWasteAll True - drift itr DecidingHeader _ + drift DecidingHeader _ = postprocess itr - drift _ _ _ + drift _ _ = return () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 7f816e8..17827d1 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -295,8 +295,16 @@ runResource (ResourceDef {..}) itr@(Interaction {..}) do setStatus $ aboStatus abo setHeader "Content-Type" defaultPageContentType mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo - output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo + putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo else when (cnfDumpTooLateAbortionToStderr itrConfig) - $ hPutStrLn stderr $ show abo + $ dumpAbortion abo runRes (driftTo Done) itr + +dumpAbortion ∷ Abortion → IO () +dumpAbortion abo + = hPutStr stderr + $ concat [ "Lucu: an exception occured after " + , "sending response header to the client:\n" + , " ", show abo, "\n" + ] diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 872e078..587c01b 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -25,6 +25,7 @@ import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) +import System.IO.Error data Context h = Context { @@ -43,13 +44,37 @@ responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → Thread responseWriter cnf h tQueue readerTID = awaitSomethingToWrite (Context cnf h tQueue readerTID) `catches` - [ Handler $ \ (_ ∷ IOException) → return () - , Handler $ \ e → case e of - ThreadKilled → return () - _ → hPutStrLn stderr (show e) - , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely" - , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e) + [ Handler handleIOE + , Handler handleAsyncE + , Handler handleBIOS + , Handler handleOthers ] + where + handleIOE ∷ IOException → IO () + handleIOE e + | isIllegalOperation e + = return () -- EPIPE: should be ignored at all. + | otherwise + = terminate e + + handleAsyncE ∷ AsyncException → IO () + handleAsyncE ThreadKilled = terminate' + handleAsyncE e = terminate e + + handleBIOS ∷ BlockedIndefinitelyOnSTM → IO () + handleBIOS = terminate + + handleOthers ∷ SomeException → IO () + handleOthers = terminate + + terminate ∷ Exception e ⇒ e → IO () + terminate e + = do hPutStrLn stderr "requestWriter caught an exception:" + hPutStrLn stderr (show $ toException e) + terminate' + + terminate' ∷ IO () + terminate' = hClose h awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO () awaitSomethingToWrite ctx@(Context {..}) diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 8f93513..c227205 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -72,7 +72,7 @@ handleStaticFile sendContent path Just mime → setContentType mime when sendContent - $ liftIO (B.readFile path) ≫= output + $ liftIO (B.readFile path) ≫= putChunk -- |@'generateETagFromFile' fpath@ generates a strong entity tag from -- a file. The file doesn't necessarily have to be a regular file; it diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index ec5b542..3b17bf8 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -32,7 +32,6 @@ helloWorld outputChunk "Hello, " outputChunk "World!\n" outputChunk =≪ Lazy.pack <$> getRemoteAddr' - , resPost = Just $ do str1 ← inputChunk 3 str2 ← inputChunk 3 -- 2.40.0