X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=520502204df5d933484d85298115051574915dd3;hb=3b448555e621530c3483f03b4b5156dc606b2035;hp=41415290961632701c97e8b9bb2c1639ba729e19;hpb=1de2506621977a383b991cadce024f626023908b;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 4141529..5205022 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -8,6 +8,7 @@
   , QuasiQuotes
   , RecordWildCards
   , UnicodeSyntax
+  , ViewPatterns
   #-}
 -- |This is the Resource Monad; monadic actions to define a behavior
 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
@@ -151,7 +152,6 @@ import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.Attempt
 import qualified Data.Attoparsec.Char8 as P
-import Data.Attoparsec.Parsable
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
@@ -159,11 +159,11 @@ import Data.Collections
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()
 import Data.Convertible.Utils
+import Data.Default
 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
@@ -181,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)
@@ -264,7 +265,7 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly (finishOff parser) (cs accept) of
+               → case P.parseOnly (finishOff def) (cs accept) of
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ cs accept
@@ -292,7 +293,7 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
-                     case P.parseOnly (finishOff parser) (cs ae) of
+                     case P.parseOnly (finishOff def) (cs ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ cs ae
@@ -316,7 +317,7 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly (finishOff parser) (cs cType) of
+               → case P.parseOnly (finishOff def) (cs cType) of
                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ cs cType
@@ -330,7 +331,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
-               → case P.parseOnly (finishOff parser) (cs auth) of
+               → case P.parseOnly (finishOff def) (cs auth) of
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
@@ -355,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
@@ -393,11 +393,14 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
-                      case P.parseOnly (finishOff parser) (cs value) of
+                      case P.parseOnly (finishOff def) (cs value) of
+                        Right []
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Empty If-Match"
                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。
-                            → when ((¬) (any (≡ tag) (tags ∷ [ETag])))
+                            → when ((¬) (any (≡ tag) tags))
                                   $ abort
                                   $ mkAbortion' PreconditionFailed
                                   $ "The entity tag doesn't match: " ⊕ cs value
@@ -421,9 +424,12 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
-                      case P.parseOnly (finishOff parser) (cs value) of
+                      case P.parseOnly (finishOff def) (cs value) of
+                        Right []
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Empty If-None-Match"
                         Right tags
-                            → when (any (≡ tag) (tags ∷ [ETag]))
+                            → when (any (≡ tag) tags)
                                   $ abort
                                   $ mkAbortion' statusForNoneMatch
                                   $ "The entity tag matches: " ⊕ cs value
@@ -450,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
@@ -465,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
@@ -478,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
@@ -490,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
@@ -617,13 +626,13 @@ getForm limit
 -- \"Location\" header field as @uri@. The @code@ must satisfy
 -- 'isRedirection' or it raises an error.
 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
-redirect sc uri
-    = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
+redirect (fromStatusCode → sc) uri
+    = do when (sc ≡ cs NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
              $ cs
              $ ("Attempted to redirect with status " ∷ Ascii)
-             ⊕ cs (fromStatusCode sc)
+             ⊕ cs sc
          setStatus sc
          setLocation uri