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
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 のみが許される。
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
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
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
$ 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"
-- 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
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
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
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 ()
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 ()
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
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
= 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)
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
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 "
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 ""
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
projects / Lucu.git / blobdiff