+ -- If-None-Match があればそれを見る。
+ ifNoneMatch ← getHeader "If-None-Match"
+ case ifNoneMatch of
+ Nothing → return ()
+ Just value → if value ≡ "*" then
+ abort statusForNoneMatch [] (Just "The entity tag matches: *")
+ else
+ case P.parseOnly p (A.toByteString value) of
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort statusForNoneMatch []
+ (Just $ "The entity tag matches: " ⊕ A.toText value)
+ Left _
+ → abort BadRequest []
+ (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
+
+ driftTo GettingBody
+ where
+ p = do xs ← eTagListP
+ P.endOfInput
+ return xs
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
+-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
+-- \"If-None-Match\" test. Be aware that any tests based on last
+-- modification time are unsafe because it is possible to mess up such
+-- tests by modifying the entity twice in a second.
+--
+-- This action is not preferred. You should use 'foundEntity' whenever
+-- possible.
+foundTimeStamp ∷ UTCTime → Resource ()
+foundTimeStamp timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
+ when (method ≡ POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundTimeStamp for POST request.")
+
+ let statusForIfModSince
+ = if method ≡ GET ∨ method ≡ HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- If-Modified-Since があればそれを見る。
+ ifModSince ← getHeader "If-Modified-Since"
+ case ifModSince of
+ 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)
+ Left _
+ → return () -- 不正な時刻は無視
+ Nothing → return ()
+
+ -- If-Unmodified-Since があればそれを見る。
+ ifUnmodSince ← getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ 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)
+ Left _
+ → return () -- 不正な時刻は無視
+ Nothing → return ()
+
+ driftTo GettingBody
+
+-- | Computation of @'foundNoEntity' mStr@ tells the system that the
+-- 'Resource' found no entity for the request URI. @mStr@ is an
+-- optional error message to be replied to the client.
+--
+-- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
+-- test and aborts with status \"412 Precondition Failed\" when it
+-- failed. If this is a GET, HEAD, POST or DELETE request,
+-- 'foundNoEntity' always aborts with status \"404 Not Found\".
+foundNoEntity ∷ Maybe Text → Resource ()
+foundNoEntity msgM
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≢ PUT)
+ $ abort NotFound [] msgM
+
+ -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+ -- If-Match: 條件も滿たさない。
+ ifMatch ← getHeader "If-Match"
+ when (ifMatch ≢ Nothing)
+ $ abort PreconditionFailed [] msgM
+
+ driftTo GettingBody
+
+
+-- Getting a request body
+
+-- | Computation of @'input' limit@ attempts to read the request body
+-- up to @limit@ bytes, and then make the 'Resource' transit to
+-- /Deciding Header/ state. When the actual size of body is larger
+-- than @limit@ bytes, computation of 'Resource' immediately aborts
+-- with status \"413 Request Entity Too Large\". When the request has
+-- no body, 'input' returns an empty string.
+--
+-- @limit@ may be less than or equal to zero. In this case, the
+-- default limitation value ('cnfMaxEntityLength') is used. See
+-- 'defaultLimit'.
+--
+-- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
+-- reading from the socket just happens at the computation of 'input',
+-- not at the evaluation of the 'Lazy.ByteString'. The same goes for
+-- 'inputChunk'.
+input ∷ Int → Resource Lazy.ByteString
+input limit
+ = do driftTo GettingBody
+ itr ← getInteraction
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
+ askForInput itr
+ else
+ do driftTo DecidingHeader
+ return (∅)
+ return chunk
+ where
+ askForInput ∷ Interaction → Resource Lazy.ByteString
+ askForInput (Interaction {..})
+ = do let confLimit = cnfMaxEntityLength itrConfig
+ actualLimit = if limit ≤ 0 then
+ confLimit
+ else
+ limit
+ when (actualLimit ≤ 0)
+ $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
+ -- Reader にリクエスト
+ liftIO $ atomically
+ $ writeTVar itrReqBodyWanted actualLimit
+ -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
+ chunk ← liftIO $ atomically
+ $ do chunkLen ← readTVar itrReceivedBodyLen
+ chunkIsOver ← readTVar itrReqChunkIsOver
+ if chunkLen < actualLimit then
+ -- 要求された量に滿たなくて、まだ殘りが
+ -- あるなら再試行。
+ unless chunkIsOver
+ $ retry
+ else
+ -- 制限値一杯まで讀むやうに指示したのに
+ -- まだ殘ってゐるなら、それは多過ぎる。
+ unless chunkIsOver
+ $ tooLarge actualLimit
+ -- 成功。itr 内にチャンクを置いたままにする
+ -- とメモリの無駄になるので除去。
+ chunk ← seqToLBS <$> readTVar itrReceivedBody
+ writeTVar itrReceivedBody (∅)
+ writeTVar itrReceivedBodyLen 0
+ return chunk
+
+ driftTo DecidingHeader
+ return chunk
+
+ tooLarge ∷ Int → STM ()
+ tooLarge lim = abortSTM RequestEntityTooLarge []
+ (Just $ "Request body must be smaller than "
+ ⊕ T.pack (show lim) ⊕ " bytes.")
+
+seqToLBS ∷ Seq ByteString → Lazy.ByteString
+{-# INLINE seqToLBS #-}
+seqToLBS = Lazy.fromChunks ∘ toList
+
+-- | Computation of @'inputChunk' limit@ attempts to read a part of
+-- request body up to @limit@ bytes. You can read any large request by
+-- repeating computation of this action. When you've read all the
+-- request body, 'inputChunk' returns an empty string and then make
+-- the 'Resource' transit to /Deciding Header/ state.
+--
+-- @limit@ may be less than or equal to zero. In this case, the
+-- default limitation value ('cnfMaxEntityLength') is used. See
+-- 'defaultLimit'.
+--
+-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
+-- should use it whenever possible.
+inputChunk ∷ Int → Resource Lazy.ByteString
+inputChunk limit
+ = do driftTo GettingBody
+ itr ← getInteraction
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
+ askForInput itr
+ else
+ do driftTo DecidingHeader
+ return (∅)
+ return chunk
+ where
+ askForInput ∷ Interaction → Resource Lazy.ByteString
+ askForInput (Interaction {..})
+ = do let confLimit = cnfMaxEntityLength itrConfig
+ actualLimit = if limit < 0 then
+ confLimit
+ else
+ limit
+ when (actualLimit ≤ 0)
+ $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
+ -- Reader にリクエスト
+ liftIO $ atomically
+ $ writeTVar itrReqBodyWanted actualLimit
+ -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
+ chunk ← liftIO $ atomically
+ $ do chunkLen ← readTVar itrReceivedBodyLen
+ -- 要求された量に滿たなくて、まだ殘りがある
+ -- なら再試行。
+ when (chunkLen < actualLimit)
+ $ do chunkIsOver ← readTVar itrReqChunkIsOver
+ unless chunkIsOver
+ $ retry
+ -- 成功
+ chunk ← seqToLBS <$> readTVar itrReceivedBody
+ writeTVar itrReceivedBody (∅)
+ writeTVar itrReceivedBodyLen 0
+ return chunk
+ when (Lazy.null chunk)
+ $ driftTo DecidingHeader
+ return chunk
+
+-- | Computation of @'inputForm' limit@ attempts to read the request
+-- body with 'input' and parse it as
+-- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
+-- the request header \"Content-Type\" is neither of them, 'inputForm'
+-- makes 'Resource' abort with status \"415 Unsupported Media
+-- Type\". If the request has no \"Content-Type\", it aborts with
+-- \"400 Bad Request\".
+--
+-- 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 UTF-8.
+inputForm ∷ Int → Resource [(Text, FormData)]
+inputForm limit
+ = do cTypeM ← getContentType
+ case cTypeM of
+ Nothing
+ → abort BadRequest [] (Just "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
+ where
+ readWWWFormURLEncoded
+ = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
+ <$>
+ (bsToAscii =≪ input 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")
+
+ readMultipartFormData params
+ = do case M.lookup "boundary" params of
+ Nothing
+ → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
+ Just boundary
+ → do src ← input 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")
+ where
+ p b = do xs ← multipartFormP b
+ P.endOfInput
+ return xs
+
+-- | This is just a constant @-1@. It's better to say @'input'
+-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
+-- the same.
+defaultLimit ∷ Int
+defaultLimit = (-1)
+
+
+-- Setting response headers
+
+-- | Set the response status code. If you omit to compute this action,
+-- the status code will be defaulted to \"200 OK\".
+setStatus ∷ StatusCode → Resource ()
+setStatus sc
+ = do driftTo DecidingHeader
+ itr ← getInteraction
+ liftIO
+ $ atomically
+ $ setResponseStatus itr sc
+
+-- | Set a value of given resource header. Comparison of header name
+-- is case-insensitive. Note that this action is not intended to be
+-- used so frequently: there should be actions like 'setContentType'
+-- for every common headers.
+--
+-- Some important headers (especially \"Content-Length\" and
+-- \"Transfer-Encoding\") may be silently dropped or overwritten by
+-- the system not to corrupt the interaction with client at the
+-- viewpoint of HTTP protocol layer. For instance, if we are keeping
+-- the connection alive, without this process it causes a catastrophe
+-- to send a header \"Content-Length: 10\" and actually send a body of
+-- 20 bytes long. In this case the client shall only accept the first
+-- 10 bytes of response body and thinks that the residual 10 bytes is
+-- a part of header of the next response.
+setHeader ∷ CIAscii → Ascii → Resource ()
+setHeader name value
+ = driftTo DecidingHeader ≫ setHeader' name value
+
+setHeader' ∷ CIAscii → Ascii → Resource ()
+setHeader' name value
+ = do itr ← getInteraction
+ liftIO $ atomically
+ $ do res ← readTVar $ itrResponse itr
+ let res' = H.setHeader name value res
+ writeTVar (itrResponse itr) res'
+ when (name ≡ "Content-Type")
+ $ writeTVar (itrResponseHasCType itr) True
+
+-- | Computation of @'redirect' code uri@ sets the response status to
+-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
+-- 'isRedirection' or it causes an error.
+redirect ∷ StatusCode → URI → Resource ()
+redirect code uri
+ = do when (code ≡ NotModified ∨ not (isRedirection code))
+ $ abort InternalServerError []
+ $ Just
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Attempted to redirect with status "
+ ⊕ printStatusCode code
+ setStatus code
+ setLocation uri
+
+-- | Computation of @'setContentType' mType@ sets the response header
+-- \"Content-Type\" to @mType@.
+setContentType ∷ MIMEType → Resource ()
+{-# INLINE setContentType #-}
+setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+
+-- | Computation of @'setLocation' uri@ sets the response header
+-- \"Location\" to @uri@.
+setLocation ∷ URI → Resource ()
+setLocation uri
+ = case A.fromChars uriStr of
+ Just a → setHeader "Location" a
+ Nothing → abort InternalServerError []
+ (Just $ "Malformed URI: " ⊕ T.pack uriStr)
+ where
+ uriStr = uriToString id uri ""
+
+-- |Computation of @'setContentEncoding' codings@ sets the response
+-- header \"Content-Encoding\" to @codings@.
+setContentEncoding ∷ [CIAscii] → Resource ()
+setContentEncoding codings
+ = do ver ← getRequestVersion
+ tr ← case ver of
+ HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
+ HttpVersion 1 1 → return toAB
+ _ → abort InternalServerError []
+ (Just "setContentEncoding: Unknown HTTP version")
+ setHeader "Content-Encoding"
+ (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
+ where
+ toAB = A.toAsciiBuilder ∘ A.fromCIAscii
+
+-- |Computation of @'setWWWAuthenticate' challenge@ sets the response
+-- header \"WWW-Authenticate\" to @challenge@.
+setWWWAuthenticate ∷ AuthChallenge → Resource ()
+setWWWAuthenticate challenge
+ = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
+
+
+-- Writing a response body
+
+-- | Write a chunk in 'Lazy.ByteString' to the response body. It is
+-- safe to apply this function to an infinitely long
+-- 'Lazy.ByteString'.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putChunk ∷ Lazy.ByteString → Resource ()
+{-# INLINE putChunk #-}
+putChunk = putBuilder ∘ BB.fromLazyByteString
+
+-- | Run a 'Builder' to construct a chunk, and write it to the
+-- response body. It is safe to apply this function to a 'Builder'
+-- producing an infinitely long stream of octets.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putBuilder ∷ Builder → Resource ()
+putBuilder b
+ = do itr ← getInteraction
+ liftIO $ atomically
+ $ do driftTo' itr DecidingBody
+ hasCType ← readTVar $ itrResponseHasCType itr
+ unless hasCType
+ $ abortSTM InternalServerError []
+ $ Just "putBuilder: Content-Type has not been set."
+ putTMVar (itrBodyToSend itr) b
+
+
+-- Private
+
+driftTo ∷ InteractionState → Resource ()
+driftTo newState
+ = do itr ← getInteraction
+ liftIO $ atomically $ driftTo' itr newState
+
+driftTo' ∷ Interaction → InteractionState → STM ()
+driftTo' itr@(Interaction {..}) newState
+ = do oldState ← readTVar itrState
+ if newState < oldState then
+ throwStateError oldState newState
+ else
+ do let a = [oldState .. newState]
+ b = tail a
+ c = zip a b
+ mapM_ (uncurry drift) c
+ writeTVar itrState newState
+ where
+ throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
+ throwStateError Done DecidingBody
+ = fail "It makes no sense to output something after finishing outputs."
+ throwStateError old new
+ = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)