From: PHO <pho@cielonegro.org>
Date: Thu, 5 Jan 2012 12:19:15 +0000 (+0900)
Subject: use time-http 0.5
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;ds=inline;p=Lucu.git

use time-http 0.5
---

diff --git a/Lucu.cabal b/Lucu.cabal
index ce5ac42..3afe50b 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -78,7 +78,7 @@ Library
         template-haskell           == 2.5.*,
         text                       == 0.11.*,
         time                       == 1.2.*,
-        time-http                  == 0.4.*,
+        time-http                  == 0.5.*,
         transformers               == 0.2.*
 
     if flag(ssl)
diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index ec92070..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
@@ -248,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
diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index e01160d..ca29c9a 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -120,15 +120,21 @@ examineAuthority localHost localPort
                          req' = updateAuthority host port req
                      in
                        setRequest req'
-               -- HTTP/1.1 requests MUST have a Host header.
+               -- HTTP/1.1 requests MUST have a Host header, but if
+               -- the requested URI has an authority, the value of
+               -- Host header must be ignored. See:
+               -- http://tools.ietf.org/html/rfc2616#section-5.2
                HttpVersion 1 1
                    → case getHeader "Host" req of
                         Just str
-                            → let (host, port)
-                                       = parseHost str
-                                  req' = updateAuthority host port req
-                              in
-                                setRequest req'
+                            | isNothing ∘ uriAuthority ∘ reqURI $ req
+                                → let (host, port)
+                                           = parseHost str
+                                      req' = updateAuthority host port req
+                                  in
+                                    setRequest req'
+                            | otherwise
+                                → return ()
                         Nothing
                             → setStatus BadRequest
                -- Should never reach here...
@@ -144,9 +150,8 @@ parseHost hp
         (hText, pAscii)
 
 updateAuthority ∷ CI Text → Ascii → Request → Request
-updateAuthority host port req
-    = let uri  = reqURI req
-          uri' = uri {
+updateAuthority host port req@(Request {..})
+    = let uri' = reqURI {
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""
                                   , uriRegName  = cs $ CI.original host
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index acc6205..5205022 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -164,7 +164,6 @@ import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
-import Data.Proxy
 import Data.Tagged
 import Data.Text (Text)
 import Data.Time
@@ -357,8 +356,7 @@ foundEntity tag timeStamp
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified"
-             $ flip proxy http
-             $ cs timeStamp
+             $ formatUTCTime timeStamp
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -458,8 +456,7 @@ foundTimeStamp timeStamp
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified"
-             $ flip proxy http
-             $ cs timeStamp
+             $ formatUTCTime timeStamp
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -473,7 +470,7 @@ foundTimeStamp timeStamp
 
          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of
-           Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+           Just str → case untag' <$> (fromAttempt $ ca str) of
                          Just lastTime
                              → when (timeStamp ≤ lastTime)
                                $ abort
@@ -486,7 +483,7 @@ foundTimeStamp timeStamp
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of
-           Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+           Just str → case untag' <$> (fromAttempt $ ca str) of
                          Just lastTime
                              → when (timeStamp > lastTime)
                                $ abort
@@ -498,6 +495,10 @@ foundTimeStamp timeStamp
            Nothing  → return ()
 
          driftTo ReceivingBody
+    where
+      untag' ∷ Tagged HTTP α → α
+      {-# INLINE untag' #-}
+      untag' = untag
 
 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 -- entity for the request URI. @mStr@ is an optional error message to