X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=7c43f96c5e7a12bcf3145771a7ea6b4976fed17e;hp=f5ccd83826f7d64e27583fb2491c75c329ecebfb;hb=246d66d6d3130e03834a6c3badc38711a1879aae;hpb=3baf479eba12bc3e9c4ef966df770cd70aa5cd81

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index f5ccd83..7c43f96 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -33,10 +33,12 @@ import Control.Applicative
 import Control.Concurrent.STM
 import Data.Ascii (Ascii)
 import Data.ByteString (ByteString)
+import Data.Convertible.Base
 import Data.Monoid.Unicode
+import Data.Proxy
 import Data.Sequence (Seq)
 import Data.Time
-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP
 import Data.Typeable
 import Network.Socket
 import Network.HTTP.Lucu.Config
@@ -49,6 +51,7 @@ import Network.HTTP.Lucu.Utils
 #if defined(HAVE_SSL)
 import OpenSSL.X509
 #endif
+import Prelude.Unicode
 
 class Typeable i ⇒ Interaction i where
     toInteraction ∷ i → SomeInteraction
@@ -85,13 +88,13 @@ instance Interaction SyntacticallyInvalidInteraction
 
 mkSyntacticallyInvalidInteraction ∷ Config
                                   → IO SyntacticallyInvalidInteraction
-mkSyntacticallyInvalidInteraction config@(Config {..})
+mkSyntacticallyInvalidInteraction conf@(Config {..})
     = do date ← getCurrentDate
          let res  = setHeader "Server"       cnfServerSoftware      $
                     setHeader "Date"         date                   $
                     setHeader "Content-Type" defaultPageContentType $
                     emptyResponse BadRequest
-             body = getDefaultPage config Nothing res
+             body = defaultPageForResponse conf Nothing res
          return SYI {
                   syiResponse   = res
                 , syiBodyToSend = body
@@ -108,7 +111,6 @@ data SemanticallyInvalidInteraction
 
       , seiResponse         ∷ !Response
       , seiWillChunkBody    ∷ !Bool
-      , seiWillDiscardBody  ∷ !Bool
       , seiWillClose        ∷ !Bool
       , seiBodyToSend       ∷ !Builder
       }
@@ -132,7 +134,7 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
                       else id
                     ) $
                     emptyResponse arInitialStatus
-             body = getDefaultPage config (Just arRequest) res
+             body = defaultPageForResponse config (Just arRequest) res
          return SEI {
                   seiRequest          = arRequest
                 , seiExpectedContinue = arExpectedContinue
@@ -140,7 +142,6 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
 
                 , seiResponse         = res
                 , seiWillChunkBody    = arWillChunkBody
-                , seiWillDiscardBody  = arWillDiscardBody
                 , seiWillClose        = arWillClose
                 , seiBodyToSend       = body
                 }
@@ -165,7 +166,6 @@ data NormalInteraction
       , niResponse         ∷ !(TVar Response)
       , niSendContinue     ∷ !(TMVar Bool)
       , niWillChunkBody    ∷ !Bool
-      , niWillDiscardBody  ∷ !(TVar Bool)
       , niWillClose        ∷ !(TVar Bool)
       , niResponseHasCType ∷ !(TVar Bool)
       -- FIXME: use TBChan Builder (in stm-chans package)
@@ -209,7 +209,6 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
 
          response         ← newTVarIO $ emptyResponse arInitialStatus
          sendContinue     ← newEmptyTMVarIO
-         willDiscardBody  ← newTVarIO arWillDiscardBody
          willClose        ← newTVarIO arWillClose
          responseHasCType ← newTVarIO False
          bodyToSend       ← newEmptyTMVarIO
@@ -233,7 +232,6 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
                 , niResponse         = response
                 , niSendContinue     = sendContinue
                 , niWillChunkBody    = arWillChunkBody
-                , niWillDiscardBody  = willDiscardBody
                 , niWillClose        = willClose
                 , niResponseHasCType = responseHasCType
                 , niBodyToSend       = bodyToSend
@@ -244,7 +242,9 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
 type InteractionQueue = TVar (Seq SomeInteraction)
 
 mkInteractionQueue ∷ IO InteractionQueue
+{-# INLINE mkInteractionQueue #-}
 mkInteractionQueue = newTVarIO (∅)
 
 getCurrentDate ∷ IO Ascii
-getCurrentDate = HTTP.toAscii <$> getCurrentTime
+{-# INLINE getCurrentDate #-}
+getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime