From: PHO 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