X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=35c9f06493d45c4cb92f65d9271c82280100d8fe;hb=3b448555e621530c3483f03b4b5156dc606b2035;hp=d36c4d1773d4ebcaad2cf2937d5ce0fcddf716b0;hpb=5f2ef377345fc47aabc63c1325df82c1cd9da9ed;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index d36c4d1..35c9f06 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -26,6 +26,7 @@ module Network.HTTP.Lucu.Interaction
     , mkInteractionQueue
 
     , getCurrentDate
+    , formatUTCTime
     )
     where
 import Blaze.ByteString.Builder (Builder)
@@ -35,8 +36,8 @@ 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.Tagged
 import Data.Time
 import Data.Time.Format.HTTP
 import Data.Typeable
@@ -47,6 +48,7 @@ import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
 import Network.HTTP.Lucu.Utils
 #if defined(HAVE_SSL)
 import OpenSSL.X509
@@ -111,7 +113,6 @@ data SemanticallyInvalidInteraction
 
       , seiResponse         ∷ !Response
       , seiWillChunkBody    ∷ !Bool
-      , seiWillDiscardBody  ∷ !Bool
       , seiWillClose        ∷ !Bool
       , seiBodyToSend       ∷ !Builder
       }
@@ -143,7 +144,6 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
 
                 , seiResponse         = res
                 , seiWillChunkBody    = arWillChunkBody
-                , seiWillDiscardBody  = arWillDiscardBody
                 , seiWillClose        = arWillClose
                 , seiBodyToSend       = body
                 }
@@ -168,7 +168,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)
@@ -212,7 +211,6 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
 
          response         ← newTVarIO $ emptyResponse arInitialStatus
          sendContinue     ← newEmptyTMVarIO
-         willDiscardBody  ← newTVarIO arWillDiscardBody
          willClose        ← newTVarIO arWillClose
          responseHasCType ← newTVarIO False
          bodyToSend       ← newEmptyTMVarIO
@@ -236,7 +234,6 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
                 , niResponse         = response
                 , niSendContinue     = sendContinue
                 , niWillChunkBody    = arWillChunkBody
-                , niWillDiscardBody  = willDiscardBody
                 , niWillClose        = willClose
                 , niResponseHasCType = responseHasCType
                 , niBodyToSend       = bodyToSend
@@ -252,4 +249,11 @@ mkInteractionQueue = newTVarIO (∅)
 
 getCurrentDate ∷ IO Ascii
 {-# INLINE getCurrentDate #-}
-getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime
+getCurrentDate = formatUTCTime <$> getCurrentTime
+
+formatUTCTime ∷ UTCTime → Ascii
+{-# INLINE formatUTCTime #-}
+formatUTCTime = cs' ∘ Tagged
+    where
+      cs' ∷ Tagged HTTP UTCTime → Ascii
+      cs' = cs