X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=6f3ecce8b851e8526e1f5eb48f6bf255656533ab;hp=64e69fbd6e9a8762145ec91f73e4569253076aa4;hb=67f9e87;hpb=b22e702f8161447a460847c6e6c97104c150534f

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 64e69fb..6f3ecce 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -71,7 +71,6 @@ module Network.HTTP.Lucu.Resource
     (
     -- * Types
       Resource(..)
-    , emptyResource
     , Rsrc
     , FormData(..)
 
@@ -150,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
@@ -213,9 +216,8 @@ getRequestVersion ∷ Rsrc HttpVersion
 getRequestVersion = reqVersion <$> getRequest
 
 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
--- @[]@ if the corresponding
--- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See:
--- 'getResourcePath'
+-- @[]@ if the corresponding 'Resource' is not greedy. See
+-- 'getResourcePath'.
 --
 -- Note that the returned path components are URI-decoded.
 getPathInfo ∷ Rsrc [Strict.ByteString]
@@ -353,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
@@ -376,7 +380,7 @@ foundETag tag
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
              $ A.fromAsciiBuilder
-             $ printETag tag
+             $ cs tag
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -447,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
@@ -461,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
@@ -664,11 +670,11 @@ setContentEncoding codings
 -- |@'setWWWAuthenticate' challenge@ declares the response header
 -- \"WWW-Authenticate\" as @challenge@.
 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
-setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
 
 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 -- must first declare the response header \"Content-Type\" before
--- applying this function. See: 'setContentType'
+-- applying this function. See 'setContentType'.
 putChunk ∷ Strict.ByteString → Rsrc ()
 putChunk = putBuilder ∘ BB.fromByteString
 
@@ -676,7 +682,7 @@ putChunk = putBuilder ∘ BB.fromByteString
 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 --
 -- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See:
--- 'setContentType'
+-- \"Content-Type\" before applying this function. See
+-- 'setContentType'.
 putChunks ∷ Lazy.ByteString → Rsrc ()
 putChunks = putBuilder ∘ BB.fromLazyByteString