X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=520502204df5d933484d85298115051574915dd3;hb=HEAD;hp=ce6c98a32c63e99af1d17effeb19eb02b7775b90;hpb=eb77281b24b8d7218e1fd80164f941836cef1d5a;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index ce6c98a..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 @@ -182,6 +181,7 @@ import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Response.StatusCode import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) @@ -356,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 @@ -457,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 @@ -472,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 @@ -485,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 @@ -497,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