From b5dc373b46987d6ef1cf1b08648cc0db584e4436 Mon Sep 17 00:00:00 2001 From: PHO Date: Thu, 15 Dec 2011 21:42:26 +0900 Subject: [PATCH] Use time-http 0.3 Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26 --- Lucu.cabal | 5 +++- Network/HTTP/Lucu/Interaction.hs | 9 ++++-- Network/HTTP/Lucu/Resource.hs | 30 ++++++++++++------- ...a377be55430e655ab42fdc4902fa56a058b26.yaml | 12 ++++++-- 4 files changed, 40 insertions(+), 16 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index a35fb08..2dcbcc8 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -51,6 +51,7 @@ Flag ssl Library Build-Depends: ascii == 0.0.*, + attempt == 0.3.*, attoparsec == 0.9.*, base == 4.*, base-unicode-symbols == 0.2.*, @@ -62,6 +63,7 @@ Library collections-api == 1.0.*, collections-base-instances == 1.0.*, containers == 0.4.*, + convertible-text == 0.4.*, directory == 1.1.*, filepath == 1.2.*, mtl == 2.0.*, @@ -70,10 +72,11 @@ Library stm == 2.2.*, stringsearch == 0.3.*, syb == 0.3.*, + tagged == 0.2.*, template-haskell == 2.5.*, text == 0.11.*, time == 1.2.*, - time-http == 0.2.*, + time-http == 0.3.*, transformers == 0.2.* if flag(ssl) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 41c74a3..d36c4d1 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -33,10 +33,12 @@ import Control.Applicative import Control.Concurrent.STM 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.Time -import qualified Data.Time.HTTP as HTTP +import Data.Time.Format.HTTP import Data.Typeable import Network.Socket import Network.HTTP.Lucu.Config @@ -49,6 +51,7 @@ import Network.HTTP.Lucu.Utils #if defined(HAVE_SSL) import OpenSSL.X509 #endif +import Prelude.Unicode class Typeable i ⇒ Interaction i where toInteraction ∷ i → SomeInteraction @@ -244,7 +247,9 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath type InteractionQueue = TVar (Seq SomeInteraction) mkInteractionQueue ∷ IO InteractionQueue +{-# INLINE mkInteractionQueue #-} mkInteractionQueue = newTVarIO (∅) getCurrentDate ∷ IO Ascii -getCurrentDate = HTTP.toAscii <$> getCurrentTime +{-# INLINE getCurrentDate #-} +getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 652c5f7..5c45ace 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -149,19 +149,23 @@ import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A +import Data.Attempt import qualified Data.Attoparsec.Char8 as P import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Data.Collections +import Data.Convertible.Base 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 qualified Data.Text as T import Data.Time -import qualified Data.Time.HTTP as HTTP +import Data.Time.Format.HTTP import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config @@ -351,7 +355,9 @@ foundEntity tag timeStamp method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" + $ flip proxy http + $ cs timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -445,7 +451,9 @@ foundTimeStamp timeStamp method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" + $ flip proxy http + $ cs timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -459,28 +467,28 @@ foundTimeStamp timeStamp ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str → case HTTP.fromAscii str of - Right lastTime + Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of + Just lastTime → when (timeStamp ≤ lastTime) $ abort $ mkAbortion' statusForIfModSince $ "The entity has not been modified since " ⊕ A.toText str - Left e + Nothing → abort $ mkAbortion' BadRequest - $ "Malformed If-Modified-Since: " ⊕ T.pack e + $ "Malformed If-Modified-Since: " ⊕ A.toText str Nothing → return () ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str → case HTTP.fromAscii str of - Right lastTime + Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of + Just lastTime → when (timeStamp > lastTime) $ abort $ mkAbortion' PreconditionFailed $ "The entity has not been modified since " ⊕ A.toText str - Left e + Nothing → abort $ mkAbortion' BadRequest - $ "Malformed If-Unmodified-Since: " ⊕ T.pack e + $ "Malformed If-Unmodified-Since: " ⊕ A.toText str Nothing → return () driftTo ReceivingBody diff --git a/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml b/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml index e731191..79fa84b 100644 --- a/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml +++ b/bugs/issue-0a2a377be55430e655ab42fdc4902fa56a058b26.yaml @@ -1,11 +1,11 @@ --- !ditz.rubyforge.org,2008-03-06/issue -title: Use convertible whenever appropriate. +title: Use convertible wherever appropriate. desc: "" type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-12-14 14:07:41.367770 Z references: [] @@ -16,4 +16,12 @@ log_events: - PHO - created - "" +- - 2011-12-15 00:08:57.500763 Z + - PHO + - edited title + - "" +- - 2011-12-15 12:42:17.264054 Z + - PHO + - changed status from unstarted to in_progress + - "" git_branch: -- 2.40.0