X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Network%2FHTTP%2FLucu%2FResource.hs;h=4cf43e0c5b7f831a45da2487e7c23fd482bf374d;hb=bb121f1189d01b5089aa5c29f0d390fad36ade48;hp=aee29d56f95682c7550623176267f23e6230d23b;hpb=9b2a30d14cbdb224d4c386a3bca45456dc336ce2;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index aee29d5..4cf43e0 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE
-    BangPatterns
+    CPP
+  , BangPatterns
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
+  , QuasiQuotes
   , RecordWildCards
   , UnicodeSyntax
   #-}
@@ -81,7 +83,9 @@ module Network.HTTP.Lucu.Resource
     , getRemoteAddr
     , getRemoteAddr'
     , getRemoteHost
+#if defined(HAVE_SSL)
     , getRemoteCertificate
+#endif
     , getRequest
     , getMethod
     , getRequestURI
@@ -151,8 +155,8 @@ 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.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
@@ -169,13 +173,17 @@ import qualified Network.HTTP.Lucu.Headers as H
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.MultipartForm
+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.MIMEType
+import Network.HTTP.Lucu.MIMEType (MIMEType(..))
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)
+import Prelude hiding (any, drop, lookup, reverse)
 import Prelude.Unicode
 
 -- |Get the string representation of the address of remote host. If
@@ -234,7 +242,7 @@ toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
-               , fdMIMEType = parseMIMEType "text/plain"
+               , fdMIMEType = [mimeType| text/plain |]
                , fdContent  = Lazy.fromChunks [value]
                }
       in (name, fd)
@@ -256,14 +264,10 @@ getAccept
            Nothing
                → return []
            Just accept
-               → case P.parseOnly p (A.toByteString accept) of
+               → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
-    where
-      p = do xs ← mimeTypeList
-             P.endOfInput
-             return xs
 
 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 -- value of request header \"Accept-Encoding\". The list is sorted in
@@ -288,15 +292,11 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
-                     case P.parseOnly p (A.toByteString ae) of
+                     case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where
-      p = do xs ← acceptEncodingList
-             P.endOfInput
-             return xs
-
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
@@ -316,14 +316,10 @@ getContentType
            Nothing
                → return Nothing
            Just cType
-               → case P.parseOnly p (A.toByteString cType) of
+               → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
-    where
-      p = do t ← mimeType
-             P.endOfInput
-             return t
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.
@@ -334,13 +330,9 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
-               → case P.parseOnly p (A.toByteString auth) of
+               → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
-    where
-      p = do ac ← authCredential
-             P.endOfInput
-             return ac
 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
@@ -395,51 +387,51 @@ foundETag tag
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"
          case ifMatch of
-           Nothing    → return ()
-           Just value → if value ≡ "*" then
-                            return ()
-                        else
-                            case P.parseOnly p (A.toByteString value) of
-                              Right tags
-                                  -- tags の中に一致するものが無ければ
-                                  -- PreconditionFailed で終了。
-                                  → when ((¬) (any (≡ tag) tags))
-                                        $ abort
-                                        $ mkAbortion' PreconditionFailed
-                                        $ "The entity tag doesn't match: " ⊕ A.toText value
-                              Left _
-                                  → abort $ mkAbortion' BadRequest
-                                          $ "Unparsable If-Match: " ⊕ A.toText value
+           Nothing
+               → return ()
+           Just value
+               → if value ≡ "*" then
+                      return ()
+                  else
+                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                        Right tags
+                            -- tags の中に一致するものが無ければ
+                            -- PreconditionFailed で終了。
+                            → when ((¬) (any (≡ tag) tags))
+                                  $ abort
+                                  $ mkAbortion' PreconditionFailed
+                                  $ "The entity tag doesn't match: " ⊕ A.toText value
+                        Left _
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable If-Match: " ⊕ A.toText value
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
          -- If-None-Match があればそれを見る。
          ifNoneMatch ← getHeader "If-None-Match"
          case ifNoneMatch of
-           Nothing    → return ()
-           Just value → if value ≡ "*" then
-                            abort $ mkAbortion' statusForNoneMatch
-                                  $ "The entity tag matches: *"
-                        else
-                            case P.parseOnly p (A.toByteString value) of
-                              Right tags
-                                  → when (any (≡ tag) tags)
-                                        $ abort
-                                        $ mkAbortion' statusForNoneMatch
-                                        $ "The entity tag matches: " ⊕ A.toText value
-                              Left _
-                                  → abort $ mkAbortion' BadRequest
-                                          $ "Unparsable If-None-Match: " ⊕ A.toText value
+           Nothing
+               → return ()
+           Just value
+               → if value ≡ "*" then
+                      abort $ mkAbortion' statusForNoneMatch
+                            $ "The entity tag matches: *"
+                  else
+                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                        Right tags
+                            → when (any (≡ tag) tags)
+                                  $ abort
+                                  $ mkAbortion' statusForNoneMatch
+                                  $ "The entity tag matches: " ⊕ A.toText value
+                        Left _
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
 
          driftTo ReceivingBody
-    where
-      p = do xs ← eTagList
-             P.endOfInput
-             return xs
 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. The only difference from 'foundEntity' is that
@@ -461,15 +453,14 @@ foundTimeStamp timeStamp
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
-               "Illegal computation of foundTimeStamp for POST request."
+               "Illegal call of foundTimeStamp for POST request."
 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
-         -- If-Modified-Since があればそれを見る。
          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of
            Just str → case HTTP.fromAscii str of
@@ -478,11 +469,11 @@ foundTimeStamp timeStamp
                                $ abort
                                $ mkAbortion' statusForIfModSince
                                $ "The entity has not been modified since " ⊕ A.toText str
-                         Left _
-                             → return () -- 不正な時刻は無視
+                         Left e
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Malformed If-Modified-Since: " ⊕ T.pack e
            Nothing  → return ()
 
-         -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of
            Just str → case HTTP.fromAscii str of
@@ -491,8 +482,9 @@ foundTimeStamp timeStamp
                                $ abort
                                $ mkAbortion' PreconditionFailed
                                $ "The entity has not been modified since " ⊕ A.toText str
-                         Left _
-                             → return () -- 不正な時刻は無視
+                         Left e
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
            Nothing  → return ()
 
          driftTo ReceivingBody
@@ -594,7 +586,7 @@ getForm limit
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "
-                       ⊕ printMIMEType cType
+                       ⊕ MT.printMIMEType cType
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
@@ -606,8 +598,8 @@ getForm limit
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 
-      readMultipartFormData params
-          = case M.lookup "boundary" params of
+      readMultipartFormData m
+          = case lookup "boundary" m of
               Nothing
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
@@ -623,16 +615,16 @@ getForm limit
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy
 -- 'isRedirection' or it raises an error.
-redirect ∷ StatusCode → URI → Resource ()
-redirect code uri
-    = do when (code ≡ NotModified ∨ not (isRedirection code))
+redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
+redirect sc uri
+    = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
-             ⊕ printStatusCode code
-         setStatus code
+             ⊕ printStatusCode sc
+         setStatus sc
          setLocation uri
 
 -- |@'setContentType' mType@ declares the response header
@@ -640,7 +632,7 @@ redirect code uri
 -- mandatory for sending a response body.
 setContentType ∷ MIMEType → Resource ()
 setContentType
-    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
 
 -- |@'setLocation' uri@ declares the response header \"Location\" as
 -- @uri@. You usually don't need to call this function directly.