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)
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
]
where
valExp ∷ Exp
- valExp = RecUpdate (var $ name "emptyResource")
+ valExp = RecUpdate (function "emptyResource")
[ FieldUpdate (UnQual (name "resGet" )) resGet
, FieldUpdate (UnQual (name "resHead")) resHead
]
(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
foundEntityStmt
= qualStmt $
metaFunction "foundEntity"
- [ var $ name "entityTag"
- , var $ name "lastModified"
+ [ var (name "entityTag")
+ , var (name "lastModified")
]
setContentTypeStmt ∷ Stmt
= 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
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")))
, resGet
= Just $ do foundEntity entityTag lastModified
setContentType contentType
- output rawData
+ putChunk rawData
, resHead
= Just $ do foundEntity entityTag lastModified
setContentType contentType
壓縮される場合は次のやうに變はる:
------------------------------------------------------------------------------
-- 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
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
, 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
-- in any 'Prelude.IO' monads or arrows.
module Network.HTTP.Lucu.Abortion
( Abortion(..)
+
, abort
, abortPurely
, abortSTM
{-# LANGUAGE
OverloadedStrings
- , RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.DefaultPage
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
= 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
-- |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
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
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
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\".
= 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
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 ()
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"
+ ]
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
+import System.IO.Error
data Context h
= Context {
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 {..})
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
outputChunk "Hello, "
outputChunk "World!\n"
outputChunk =≪ Lazy.pack <$> getRemoteAddr'
-
, resPost
= Just $ do str1 ← inputChunk 3
str2 ← inputChunk 3
projects / Lucu.git / commitdiff