Still making many changes...

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/ImplantFile.hs b/ImplantFile.hs
index b085a9876b859c4463c11609524da25082b48f4d..67633f763e3db855c6b4d4f6c39eeb62bb56aa1b 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -126,15 +126,19 @@ generateHaskellSource opts srcFile
 
          let hsModule = mkModule modName symName imports decls
              imports  = mkImports useGZip
 
          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)
 
          hPutStrLn output header
          hPutStrLn output (prettyPrint hsModule)


@@ -159,10 +163,16 @@ mkImports useGZip
                    False False Nothing Nothing Nothing
       ]
       ⧺
                    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
 
 resourceDecl ∷ Name → Bool → [Decl]
 resourceDecl symName useGZip


@@ -171,7 +181,7 @@ resourceDecl symName useGZip
       ]
     where
       valExp ∷ Exp
       ]
     where
       valExp ∷ Exp

-      valExp = RecUpdate (var $ name "emptyResource")
+      valExp = RecUpdate (function "emptyResource")

                [ FieldUpdate (UnQual (name "resGet" )) resGet
                , FieldUpdate (UnQual (name "resHead")) resHead
                ]
                [ FieldUpdate (UnQual (name "resGet" )) resGet
                , FieldUpdate (UnQual (name "resHead")) resHead
                ]


@@ -215,17 +225,14 @@ resGetGZipped
                (doE [ setContentEncodingGZipStmt
                     , outputStmt (var dataVarName)
                     ])
                (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
 
 resGetRaw ∷ Exp
 resGetRaw
     = function "Just" `app`
       paren (doE [ foundEntityStmt
                  , setContentTypeStmt

-                 , outputStmt (var $ name "rawData")
+                 , outputStmt (function "rawData")

                  ])
 
 setContentEncodingGZipStmt ∷ Stmt
                  ])
 
 setContentEncodingGZipStmt ∷ Stmt


@@ -240,8 +247,8 @@ foundEntityStmt ∷ Stmt
 foundEntityStmt
     = qualStmt $
       metaFunction "foundEntity"
 foundEntityStmt
     = qualStmt $
       metaFunction "foundEntity"

-                       [ var $ name "entityTag"
-                       , var $ name "lastModified"
+                       [ var (name "entityTag")
+                       , var (name "lastModified")

                        ]
 
 setContentTypeStmt ∷ Stmt
                        ]
 
 setContentTypeStmt ∷ Stmt


@@ -249,12 +256,12 @@ setContentTypeStmt
     = qualStmt
       ( function "setContentType"
         `app`
     = qualStmt
       ( function "setContentType"
         `app`

-        var (name "contentType")
+        function "contentType"

       )
 
 outputStmt ∷ Exp → Stmt
 outputStmt e
       )
 
 outputStmt ∷ Exp → Stmt
 outputStmt e

-    = qualStmt $ function "output" `app` e
+    = qualStmt $ function "putChunk" `app` e

 
 entityTagDecl ∷ ETag → [Decl]
 entityTagDecl eTag
 
 entityTagDecl ∷ ETag → [Decl]
 entityTagDecl eTag


@@ -295,6 +302,84 @@ contentTypeDecl mime
       mimeToString ∷ MIMEType → String
       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 
       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")))
 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
         , resGet
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType

-                        output rawData
+                        putChunk rawData

         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType


@@ -500,7 +585,9 @@ openOutput opts
   壓縮される場合は次のやうに變はる:
   ------------------------------------------------------------------------------
   -- import に追加
   壓縮される場合は次のやうに變はる:
   ------------------------------------------------------------------------------
   -- 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
 
   -- ResourceDef は次のやうに變化
   baz ∷ ResourceDef


@@ -514,9 +601,9 @@ openOutput opts
                         gzipAllowed ← isEncodingAcceptable "gzip"
                         if gzipAllowed then
                             do setContentEncoding ["gzip"]
                         gzipAllowed ← isEncodingAcceptable "gzip"
                         if gzipAllowed then
                             do setContentEncoding ["gzip"]

-                               output gzippedData
+                               putChunk gzippedData

                         else
                         else

-                            output (decompress gzippedData)
+                            gunzipAndPutChunk gzippedData

         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType


@@ -524,6 +611,15 @@ openOutput opts
         , resPut    = Nothing
         , resDelete = Nothing
         }
         , 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
   
   -- rawData の代はりに gzippedData
   gzippedData ∷ Lazy.ByteString

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index eeb1c6b7675ec1e40ba369c8c25035042d657ec3..0099576e62e04c631ae00a528ea0c55cb02eb6c5 100644 (file)
--- 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(..)
 -- in any 'Prelude.IO' monads or arrows.
 module Network.HTTP.Lucu.Abortion
     ( Abortion(..)

+

     , abort
     , abortPurely
     , abortSTM
     , abort
     , abortPurely
     , abortSTM

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 785e4c19480d385d2bc783cd441a2fc800983bf7..70d4a6a278b29c6aa6f3e70ba31b3d2920565e1f 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE
     OverloadedStrings
 {-# LANGUAGE
     OverloadedStrings

-  , RecordWildCards

   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 37a3ad6f25a7f1eb1a35da9e74ac7de01d7224b6..eabc06ffe5808c9ee6c7b420172173730fb1534a 100644 (file)
--- 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)
       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
                   ]
 
       mimeToString ∷ MIMEType → String

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 554fa39e52c228463f13fd05a736465a20ced5f0..a80ecaeb7024e93a8e8d0db352e1a13bf307f130 100644 (file)
--- 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`
     = 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
 
 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 d0454c4c630d047a419f335a37ecfeb1c64211cb..ddff647364a4295361379926b5affcff571a7081 100644 (file)
--- 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/.
 
     -- |Computation of these actions changes the state to /Deciding
     -- Body/.

-    , output
-    , outputChunk
+    , putChunk
+    , putBuilder

 
     , driftTo -- private
     )
     where
 
     , driftTo -- private
     )
     where

+import Blaze.ByteString.Builder (Builder)

 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative
 import Control.Concurrent.STM
 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative
 import Control.Concurrent.STM


@@ -410,7 +411,7 @@ getAuthorization
              return ac
 
 
              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
 
 -- |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
 
 
          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
 
 -- | 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)
 
 
 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\".
 
 -- | 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)
 
 
     = 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'
 -- 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'
 -- 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
          liftIO $ atomically

-                $ do hasCType ← readTVar $ itrResponseHasCType itr
+                $ do driftTo' itr DecidingBody
+                     hasCType ← readTVar $ itrResponseHasCType itr

                      unless hasCType
                          $ abortSTM InternalServerError []
                      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
 
 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
     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)
 
       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
           = writeTVar itrReqBodyWasteAll True

-      drift itr DecidingHeader _
+      drift DecidingHeader _

           = postprocess itr
           = postprocess itr

-      drift _ _ _
+      drift _ _

           = return ()
           = return ()

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 7f816e8feabb667139db9c1d903eacaa53e4a152..17827d12369d4eb950220ff48be0dd0cbde6d8ba 100644 (file)
--- 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
                        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)
                else
                    when (cnfDumpTooLateAbortionToStderr itrConfig)

-                       $ hPutStrLn stderr $ show abo
+                       $ dumpAbortion abo

                runRes (driftTo Done) itr
                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 872e07807adc12c77245818e7dff61cbf947ea27..587c01b695b1de62111a14ce9a70772cf467aa50 100644 (file)
--- 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 Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)

+import System.IO.Error

 
 data Context h
     = Context {
 
 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`
 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 {..})
 
 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
 awaitSomethingToWrite ctx@(Context {..})

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index 8f93513659affc2dbf5c0ddbe31fe27eab6929ae..c227205a3759a6df79fbe2eb9498c2c46eba9fe0 100644 (file)
--- 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
            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
 
 -- |@'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 ec5b542fb91a82fcb7679d35709ca74bca9487dc..3b17bf8bd08a08976fd79577628678bea1ada6eb 100644 (file)
--- a/examples/HelloWorld.hs
+++ b/examples/HelloWorld.hs
@@ -32,7 +32,6 @@ helloWorld
                       outputChunk "Hello, "
                       outputChunk "World!\n"
                       outputChunk =≪ Lazy.pack <$> getRemoteAddr'
                       outputChunk "Hello, "
                       outputChunk "World!\n"
                       outputChunk =≪ Lazy.pack <$> getRemoteAddr'

-                      

       , resPost
           = Just $ do str1 ← inputChunk 3
                       str2 ← inputChunk 3
       , resPost
           = Just $ do str1 ← inputChunk 3
                       str2 ← inputChunk 3