+ p = do ac ← authCredentialP
+ P.endOfInput
+ return ac
+
+
+{- ExaminingRequest 時に使用するアクション群 -}
+
+-- |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
+-- a datum to be replied. If this is a PUT or DELETE request, it means
+-- a datum which was stored for the URI until now. It is an error to
+-- compute 'foundEntity' if this is a POST request.
+--
+-- Computation of 'foundEntity' performs \"If-Match\" test or
+-- \"If-None-Match\" test if possible. When those tests fail, the
+-- computation of 'Resource' immediately aborts with status \"412
+-- Precondition Failed\" or \"304 Not Modified\" depending on the
+-- situation.
+--
+-- If this is a GET or HEAD request, 'foundEntity' automatically puts
+-- \"ETag\" and \"Last-Modified\" headers into the response.
+foundEntity ∷ ETag → UTCTime → Resource ()
+foundEntity tag 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 foundEntity for a POST request.")
+ foundETag tag
+
+ driftTo GettingBody
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
+-- the response.
+--
+-- This action is not preferred. You should use 'foundEntity' whenever
+-- possible.
+foundETag ∷ ETag → Resource ()
+foundETag tag
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader' "ETag"
+ $ A.fromAsciiBuilder
+ $ printETag tag
+ when (method ≡ POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundETag for POST request.")
+
+ -- 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 PreconditionFailed []
+ (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
+ Left _
+ → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
+
+ let statusForNoneMatch
+ = if method ≡ GET ∨ method ≡ HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- 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
+
+
+{- GettingBody 時に使用するアクション群 -}
+
+-- | 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 reqHasBody $ 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 reqHasBody $ 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)
+
+
+{- DecidingHeader 時に使用するアクション群 -}
+
+-- | 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'
+
+-- | 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 ()
+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)
+
+
+{- DecidingBody 時に使用するアクション群 -}
+
+-- | Write a 'Lazy.ByteString' to the response body, and then transit
+-- to the /Done/ state. It is safe to apply 'output' to an infinite
+-- string, such as the lazy stream of \/dev\/random.
+output ∷ Lazy.ByteString → Resource ()
+{-# INLINE output #-}
+output str = outputChunk str *> driftTo Done
+
+-- | Write a 'Lazy.ByteString' to the response body. This action can
+-- be repeated as many times as you want. It is safe to apply
+-- 'outputChunk' to an infinite string.
+outputChunk ∷ Lazy.ByteString → Resource ()
+outputChunk str
+ = do driftTo DecidingBody
+ itr ← getInteraction
+ liftIO $ atomically
+ $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
+ unless (Lazy.null str)
+ $ writeTVar (itrSentNoBodySoFar itr) False
+
+{-
+
+ [GettingBody からそれ以降の状態に遷移する時]
+
+ body を讀み終へてゐなければ、殘りの body を讀み捨てる。
+
+
+ [DecidingHeader からそれ以降の状態に遷移する時]
+
+ postprocess する。
+
+
+ [Done に遷移する時]
+
+ bodyIsNull が False ならば何もしない。True だった場合は出力補完す
+ る。
+
+-}
+
+driftTo ∷ InteractionState → Resource ()
+driftTo newState
+ = do itr ← getInteraction
+ liftIO $ atomically
+ $ do oldState ← readTVar $ itrState itr
+ if newState < oldState then
+ throwStateError oldState newState
+ else
+ do let a = [oldState .. newState]
+ b = tail a
+ c = zip a b
+ mapM_ (uncurry $ drift itr) c
+ writeTVar (itrState itr) newState
+ where
+ throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
+ throwStateError Done DecidingBody
+ = fail "It makes no sense to output something after finishing to output."
+ throwStateError old new
+ = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
+
+ drift ∷ Interaction → InteractionState → InteractionState → STM ()
+ drift (Interaction {..}) GettingBody _
+ = writeTVar itrReqBodyWasteAll True
+ drift itr DecidingHeader _
+ = postprocess itr
+ drift itr@(Interaction {..}) _ Done
+ = do bodyIsNull ← readTVar itrSentNoBodySoFar
+ when bodyIsNull
+ $ writeDefaultPage itr
+ drift _ _ _
+ = return ()