use time-http 0.5

diff --git a/Lucu.cabal b/Lucu.cabal
index ce5ac42589be5da90b99995815e67ea11de03983..3afe50bb4d32ffda98822e1f49c91b4724be38dc 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -78,7 +78,7 @@ Library
         template-haskell           == 2.5.*,
         text                       == 0.11.*,
         time                       == 1.2.*,
         template-haskell           == 2.5.*,
         text                       == 0.11.*,
         time                       == 1.2.*,

-        time-http                  == 0.4.*,
+        time-http                  == 0.5.*,

         transformers               == 0.2.*
 
     if flag(ssl)
         transformers               == 0.2.*
 
     if flag(ssl)

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index ec9207032ce845a0fb68e0bd963a8b08d3953fd1..35c9f06493d45c4cb92f65d9271c82280100d8fe 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -26,6 +26,7 @@ module Network.HTTP.Lucu.Interaction
     , mkInteractionQueue
 
     , getCurrentDate
     , mkInteractionQueue
 
     , getCurrentDate

+    , formatUTCTime

     )
     where
 import Blaze.ByteString.Builder (Builder)
     )
     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.ByteString (ByteString)
 import Data.Convertible.Base
 import Data.Monoid.Unicode

-import Data.Proxy

 import Data.Sequence (Seq)
 import Data.Sequence (Seq)

+import Data.Tagged

 import Data.Time
 import Data.Time.Format.HTTP
 import Data.Typeable
 import Data.Time
 import Data.Time.Format.HTTP
 import Data.Typeable


@@ -248,4 +249,11 @@ mkInteractionQueue = newTVarIO (∅)
 
 getCurrentDate ∷ IO Ascii
 {-# INLINE getCurrentDate #-}
 
 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 e01160dafe6ef46acd1888731abdd0b477943fd9..ca29c9a12e531432c66fcc9deced4be509820352 100644 (file)
--- 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'
                          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
                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...
                         Nothing
                             → setStatus BadRequest
                -- Should never reach here...


@@ -144,9 +150,8 @@ parseHost hp
         (hText, pAscii)
 
 updateAuthority ∷ CI Text → Ascii → Request → Request
         (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
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""
                                   , uriRegName  = cs $ CI.original host

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index acc62057549f0527e40daac13e6024ff7395bda6..520502204df5d933484d85298115051574915dd3 100644 (file)
--- 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.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode

-import Data.Proxy

 import Data.Tagged
 import Data.Text (Text)
 import Data.Time
 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"
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified"

-             $ flip proxy http
-             $ cs timeStamp
+             $ formatUTCTime timeStamp

          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError


@@ -458,8 +456,7 @@ foundTimeStamp timeStamp
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified"
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified"

-             $ flip proxy http
-             $ cs timeStamp
+             $ formatUTCTime timeStamp

          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError


@@ -473,7 +470,7 @@ foundTimeStamp timeStamp
 
          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of
 
          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
                          Just lastTime
                              → when (timeStamp ≤ lastTime)
                                $ abort


@@ -486,7 +483,7 @@ foundTimeStamp timeStamp
 
          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of
 
          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
                          Just lastTime
                              → when (timeStamp > lastTime)
                                $ abort


@@ -498,6 +495,10 @@ foundTimeStamp timeStamp
            Nothing  → return ()
 
          driftTo ReceivingBody
            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
 
 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 -- entity for the request URI. @mStr@ is an optional error message to