X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=d61f2f45ec3950505020c19c770559ecdd0a2d3b;hb=9668dc27a02b59d7bfb1e9e40af3d2619700ad69;hp=eed224f11bd797f68ed2517d56dd465b4183f64f;hpb=7843dbf537dfefa583a8ee55b2a31a5e8a9c7c37;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index eed224f..d61f2f4 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -28,8 +28,8 @@
 -- /Examining Request/ and the final state is /Done/.
 --
 --   [/Examining Request/] In this state, a 'Resource' looks at the
---   request header fields and thinks about a corresponding entity for
---   it. If there is a suitable entity, the 'Resource' tells the
+--   request header fields and thinks about the corresponding entity
+--   for it. If there is a suitable entity, the 'Resource' tells the
 --   system an entity tag and its last modification time
 --   ('foundEntity'). If it found no entity, it tells the system so
 --   ('foundNoEntity'). In case it is impossible to decide the
@@ -41,11 +41,11 @@
 --   socket, the system sends \"100 Continue\" to the client if need
 --   be. When a 'Resource' transits to the next state without
 --   receiving all or part of a request body, the system automatically
---   receives and discards it.
+--   discards it.
 --
---   [/Deciding Header/] A 'Resource' makes a decision of status code
---   and response header fields. When it transits to the next state,
---   the system validates and completes the response header fields and
+--   [/Deciding Header/] A 'Resource' makes a decision of response
+--   status code and header fields. When it transits to the next
+--   state, the system validates and completes the header fields and
 --   then sends them to the client.
 --
 --   [/Sending Body/] In this state, a 'Resource' asks the system to
@@ -69,6 +69,8 @@ module Network.HTTP.Lucu.Resource
     (
     -- * Types
       Resource
+    , ResourceDef(..)
+    , emptyResource
     , FormData(..)
 
     -- * Getting request header
@@ -101,6 +103,7 @@ module Network.HTTP.Lucu.Resource
     , foundETag
     , foundTimeStamp
     , foundNoEntity
+    , foundNoEntity'
 
     -- * Receiving a request body
     -- |These functions make the 'Resource' transit to the /Receiving
@@ -125,8 +128,9 @@ module Network.HTTP.Lucu.Resource
     , deleteHeader
 
     -- * Sending a response body
-    -- |These functions make the 'Resource' transit to the /Sending
-    -- Body/ state.
+
+    -- |These functions make the 'Resource' transit to the
+    -- /Sending Body/ state.
     , putChunk
     , putChunks
     , putBuilder
@@ -158,7 +162,7 @@ import qualified Data.Text.Encoding as T
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Authorization
+import Network.HTTP.Lucu.Authentication
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.ContentCoding
 import Network.HTTP.Lucu.ETag
@@ -205,21 +209,17 @@ getRequestVersion = reqVersion <$> getRequest
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 -- 'getResourcePath'.
 --
--- Note that the returned path is URI-decoded and then UTF-8 decoded.
-getPathInfo ∷ Resource [Text]
+-- Note that the returned path components are URI-decoded.
+getPathInfo ∷ Resource [Strict.ByteString]
 getPathInfo = do rsrcPath ← getResourcePath
                  reqPath  ← splitPathInfo <$> getRequestURI
-                 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
-                 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
-                 -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
-                 -- ければこの Resource が撰ばれた筈が無い）ので、
-                 -- rsrcPath の長さの分だけ削除すれば良い。
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request
--- body. Field names are decoded in UTF-8. See 'getForm'.
+-- body. Field names are decoded in UTF-8 for an hardly avoidable
+-- reason. See 'getForm'.
 getQueryForm ∷ Resource [(Text, FormData)]
 getQueryForm = parse' <$> getRequestURI
     where
@@ -241,7 +241,7 @@ toPairWithFormData (name, value)
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that
 -- this function is not intended to be used so frequently: there
--- should be actions like 'getContentType' for every common headers.
+-- should be functions like 'getContentType' for every common headers.
 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest
@@ -257,8 +257,8 @@ getAccept
            Just accept
                → case P.parseOnly p (A.toByteString accept) of
                     Right xs → return xs
-                    Left  _  → abort BadRequest []
-                               (Just $ "Unparsable Accept: " ⊕ A.toText accept)
+                    Left  _  → abort $ mkAbortion' BadRequest
+                                     $ "Unparsable Accept: " ⊕ A.toText accept
     where
       p = do xs ← mimeTypeListP
              P.endOfInput
@@ -280,8 +280,8 @@ getAcceptEncoding
                     case ver of
                       HttpVersion 1 0 → return [("identity", Nothing)]
                       HttpVersion 1 1 → return [("*"       , Nothing)]
-                      _               → abort InternalServerError []
-                                        (Just "getAcceptEncoding: unknown HTTP version")
+                      _               → abort $ mkAbortion' InternalServerError
+                                                "getAcceptEncoding: unknown HTTP version"
            Just ae
                → if ae ≡ "" then
                       -- identity のみが許される。
@@ -289,8 +289,8 @@ getAcceptEncoding
                  else
                      case P.parseOnly p (A.toByteString ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
-                       Left  _  → abort BadRequest []
-                                  (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
+                       Left  _  → abort $ mkAbortion' BadRequest
+                                        $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where
       p = do xs ← acceptEncodingListP
              P.endOfInput
@@ -299,7 +299,8 @@ getAcceptEncoding
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
--- |Return 'True' iff a given content-coding is acceptable.
+-- |Return 'True' iff a given content-coding is acceptable by the
+-- client.
 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where
@@ -316,8 +317,8 @@ getContentType
            Just cType
                → case P.parseOnly p (A.toByteString cType) of
                     Right t → return $ Just t
-                    Left  _ → abort BadRequest []
-                              (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
+                    Left  _ → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable Content-Type: " ⊕ A.toText cType
     where
       p = do t ← mimeTypeP
              P.endOfInput
@@ -362,8 +363,9 @@ foundEntity tag timeStamp
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)
-             $ abort InternalServerError []
-               (Just "foundEntity: this is a POST request.")
+             $ abort
+             $ mkAbortion' InternalServerError
+               "foundEntity: this is a POST request."
          foundETag tag
 
          driftTo ReceivingBody
@@ -385,8 +387,9 @@ foundETag tag
              $ A.fromAsciiBuilder
              $ printETag tag
          when (method ≡ POST)
-             $ abort InternalServerError []
-             $ Just "Illegal computation of foundETag for POST request."
+             $ abort
+             $ mkAbortion' InternalServerError
+               "Illegal computation of foundETag for POST request."
 
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"
@@ -400,13 +403,12 @@ foundETag tag
                                   -- tags の中に一致するものが無ければ
                                   -- PreconditionFailed で終了。
                                   → when ((¬) (any (≡ tag) tags))
-                                        $ abort PreconditionFailed []
-                                        $ Just
+                                        $ abort
+                                        $ mkAbortion' PreconditionFailed
                                         $ "The entity tag doesn't match: " ⊕ A.toText value
                               Left _
-                                  → abort BadRequest []
-                                    $ Just
-                                    $ "Unparsable If-Match: " ⊕ A.toText value
+                                  → abort $ mkAbortion' BadRequest
+                                          $ "Unparsable If-Match: " ⊕ A.toText value
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
@@ -419,18 +421,18 @@ foundETag tag
          case ifNoneMatch of
            Nothing    → return ()
            Just value → if value ≡ "*" then
-                            abort statusForNoneMatch [] (Just "The entity tag matches: *")
+                            abort $ mkAbortion' statusForNoneMatch
+                                  $ "The entity tag matches: *"
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)
-                                        $ abort statusForNoneMatch []
-                                        $ Just
+                                        $ abort
+                                        $ mkAbortion' statusForNoneMatch
                                         $ "The entity tag matches: " ⊕ A.toText value
                               Left _
-                                  → abort BadRequest []
-                                    $ Just
-                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+                                  → abort $ mkAbortion' BadRequest
+                                          $ "Unparsable If-None-Match: " ⊕ A.toText value
 
          driftTo ReceivingBody
     where
@@ -456,8 +458,9 @@ foundTimeStamp timeStamp
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)
-             $ abort InternalServerError []
-               (Just "Illegal computation of foundTimeStamp for POST request.")
+             $ abort
+             $ mkAbortion' InternalServerError
+               "Illegal computation of foundTimeStamp for POST request."
 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then
@@ -471,8 +474,9 @@ foundTimeStamp timeStamp
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp ≤ lastTime)
-                               $ abort statusForIfModSince []
-                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
+                               $ abort
+                               $ mkAbortion' statusForIfModSince
+                               $ "The entity has not been modified since " ⊕ A.toText str
                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
@@ -483,8 +487,9 @@ foundTimeStamp timeStamp
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp > lastTime)
-                               $ abort PreconditionFailed []
-                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
+                               $ abort
+                               $ mkAbortion' PreconditionFailed
+                               $ "The entity has not been modified since " ⊕ A.toText str
                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
@@ -505,16 +510,23 @@ foundNoEntity msgM
 
          method ← getMethod
          when (method ≢ PUT)
-             $ abort NotFound [] msgM
+             $ abort
+             $ mkAbortion NotFound [] msgM
 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- If-Match: 條件も滿たさない。
          ifMatch ← getHeader "If-Match"
          when (ifMatch ≢ Nothing)
-             $ abort PreconditionFailed [] msgM
+             $ abort
+             $ mkAbortion PreconditionFailed [] msgM
 
          driftTo ReceivingBody
 
+-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
+foundNoEntity' ∷ Resource ()
+{-# INLINE foundNoEntity' #-}
+foundNoEntity' = foundNoEntity Nothing
+
 
 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the
@@ -526,8 +538,8 @@ foundNoEntity msgM
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 -- limitation value ('cnfMaxEntityLength') instead.
 --
--- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of
+-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
+-- lazy: reading from the socket just happens at the computation of
 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 getChunks ∷ Maybe Int → Resource Lazy.ByteString
 getChunks (Just n)
@@ -541,10 +553,15 @@ getChunks' ∷ Int → Resource Lazy.ByteString
 getChunks' limit = go limit (∅)
     where
       go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
-      go 0 _  = abort RequestEntityTooLarge []
-                (Just $ "Request body must be smaller than "
-                        ⊕ T.pack (show limit) ⊕ " bytes.")
-      go n xs = do let n'  = min n Lazy.defaultChunkSize
+      go 0 _  = do chunk ← getChunk 1
+                   if Strict.null chunk then
+                       return (∅)
+                   else
+                       abort $ mkAbortion' RequestEntityTooLarge
+                             $ "Request body must be smaller than "
+                             ⊕ T.pack (show limit)
+                             ⊕ " bytes."
+      go n xs = do let n' = min n Lazy.defaultChunkSize
                    chunk ← getChunk n'
                    if Strict.null chunk then
                        -- Got EOF
@@ -563,8 +580,8 @@ getChunks' limit = go limit (∅)
 --
 -- Field names in @multipart\/form-data@ will be precisely decoded in
 -- accordance with RFC 2231. On the other hand,
--- @application\/x-www-form-urlencoded@ says nothing about the
--- encoding of field names, so they'll always be decoded in
+-- @application\/x-www-form-urlencoded@ says nothing about character
+-- encodings for field names, so they'll always be decoded in
 -- UTF-8. (This could be a bad design, but I can't think of any better
 -- idea.)
 getForm ∷ Maybe Int → Resource [(Text, FormData)]
@@ -572,18 +589,17 @@ getForm limit
     = do cTypeM ← getContentType
          case cTypeM of
            Nothing
-               → abort BadRequest [] (Just "Missing Content-Type")
+               → abort $ mkAbortion' BadRequest "Missing Content-Type"
            Just (MIMEType "application" "x-www-form-urlencoded" _)
                → readWWWFormURLEncoded
            Just (MIMEType "multipart" "form-data" params)
                → readMultipartFormData params
            Just cType
-               → abort UnsupportedMediaType []
-                 $ Just
-                 $ A.toText
-                 $ A.fromAsciiBuilder
-                 $ A.toAsciiBuilder "Unsupported media type: "
-                 ⊕ printMIMEType cType
+               → abort $ mkAbortion' UnsupportedMediaType
+                       $ A.toText
+                       $ A.fromAsciiBuilder
+                       $ A.toAsciiBuilder "Unsupported media type: "
+                       ⊕ printMIMEType cType
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
@@ -593,22 +609,22 @@ getForm limit
       bsToAscii bs
           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
               Just a  → return a
-              Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
+              Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 
       readMultipartFormData params
-          = do case M.lookup "boundary" params of
-                 Nothing
-                     → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
-                 Just boundary
-                     → do src ← getChunks limit
-                          b   ← case A.fromText boundary of
-                                   Just b  → return b
-                                   Nothing → abort BadRequest []
-                                             (Just $ "Malformed boundary: " ⊕ boundary)
-                          case LP.parse (p b) src of
-                            LP.Done _ formList
-                                → return formList
-                            _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
+          = case M.lookup "boundary" params of
+              Nothing
+                  → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
+              Just boundary
+                  → do src ← getChunks limit
+                       b   ← case A.fromText boundary of
+                                Just b  → return b
+                                Nothing → abort $ mkAbortion' BadRequest
+                                                $ "Malformed boundary: " ⊕ boundary
+                       case LP.parse (p b) src of
+                         LP.Done _ formList
+                             → return formList
+                         _   → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data"
           where
             p b = do xs ← multipartFormP b
                      P.endOfInput
@@ -620,8 +636,8 @@ getForm limit
 redirect ∷ StatusCode → URI → Resource ()
 redirect code uri
     = do when (code ≡ NotModified ∨ not (isRedirection code))
-             $ abort InternalServerError []
-             $ Just
+             $ abort
+             $ mkAbortion' InternalServerError
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
@@ -642,8 +658,8 @@ setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a
-        Nothing → abort InternalServerError []
-                  (Just $ "Malformed URI: " ⊕ T.pack uriStr)
+        Nothing → abort $ mkAbortion' InternalServerError
+                        $ "Malformed URI: " ⊕ T.pack uriStr
     where
       uriStr = uriToString id uri ""
 
@@ -655,8 +671,8 @@ setContentEncoding codings
          tr  ← case ver of
                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                   HttpVersion 1 1 → return toAB
-                  _               → abort InternalServerError []
-                                    (Just "setContentEncoding: Unknown HTTP version")
+                  _               → abort $ mkAbortion' InternalServerError
+                                            "setContentEncoding: Unknown HTTP version"
          setHeader "Content-Encoding"
                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
     where
@@ -673,9 +689,8 @@ setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 putChunk ∷ Strict.ByteString → Resource ()
 putChunk = putBuilder ∘ BB.fromByteString
 
--- |Write a chunk in 'Lazy.ByteString' to the response body. It is
--- safe to apply this function to an infinitely long
--- 'Lazy.ByteString'.
+-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
+-- 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