import qualified Data.ByteString.Lazy as Lazy
import Data.Collections
import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Convertible.Utils
import Data.List (intersperse, sort)
import Data.Maybe
import Data.Monoid
where
parse' = map toPairWithFormData ∘
parseWWWFormURLEncoded ∘
- fromJust ∘
- A.fromChars ∘
+ convertUnsafe ∘
drop 1 ∘
uriQuery
Nothing
→ return []
Just accept
- → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
+ → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of
Right xs → return xs
Left _ → abort $ mkAbortion' BadRequest
- $ "Unparsable Accept: " ⊕ A.toText accept
+ $ "Unparsable Accept: " ⊕ cs accept
-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
-- value of request header \"Accept-Encoding\". The list is sorted in
-- identity のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
+ case P.parseOnly (finishOff acceptEncodingList) (cs ae) of
Right xs → return $ map toTuple $ reverse $ sort xs
Left _ → abort $ mkAbortion' BadRequest
- $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
+ $ "Unparsable Accept-Encoding: " ⊕ cs ae
where
toTuple (AcceptEncoding {..})
= (aeEncoding, aeQValue)
Nothing
→ return Nothing
Just cType
- → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
+ → case P.parseOnly (finishOff MT.mimeType) (cs cType) of
Right t → return $ Just t
Left _ → abort $ mkAbortion' BadRequest
- $ "Unparsable Content-Type: " ⊕ A.toText cType
+ $ "Unparsable Content-Type: " ⊕ cs cType
-- |Return the value of request header \"Authorization\" as
-- 'AuthCredential'.
Nothing
→ return Nothing
Just auth
- → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
+ → case P.parseOnly (finishOff authCredential) (cs auth) of
Right ac → return $ Just ac
Left _ → return Nothing
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "ETag"
- $ A.fromAsciiBuilder
$ cs tag
when (method ≡ POST)
$ abort
→ if value ≡ "*" then
return ()
else
- case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ case P.parseOnly (finishOff eTagList) (cs value) of
Right tags
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
→ when ((¬) (any (≡ tag) tags))
$ abort
$ mkAbortion' PreconditionFailed
- $ "The entity tag doesn't match: " ⊕ A.toText value
+ $ "The entity tag doesn't match: " ⊕ cs value
Left _
→ abort $ mkAbortion' BadRequest
- $ "Unparsable If-Match: " ⊕ A.toText value
+ $ "Unparsable If-Match: " ⊕ cs value
let statusForNoneMatch
= if method ≡ GET ∨ method ≡ HEAD then
abort $ mkAbortion' statusForNoneMatch
$ "The entity tag matches: *"
else
- case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ case P.parseOnly (finishOff eTagList) (cs value) of
Right tags
→ when (any (≡ tag) tags)
$ abort
$ mkAbortion' statusForNoneMatch
- $ "The entity tag matches: " ⊕ A.toText value
+ $ "The entity tag matches: " ⊕ cs value
Left _
→ abort $ mkAbortion' BadRequest
- $ "Unparsable If-None-Match: " ⊕ A.toText value
+ $ "Unparsable If-None-Match: " ⊕ cs value
driftTo ReceivingBody
→ when (timeStamp ≤ lastTime)
$ abort
$ mkAbortion' statusForIfModSince
- $ "The entity has not been modified since " ⊕ A.toText str
+ $ "The entity has not been modified since " ⊕ cs str
Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Modified-Since: " ⊕ A.toText str
+ $ "Malformed If-Modified-Since: " ⊕ cs str
Nothing → return ()
ifUnmodSince ← getHeader "If-Unmodified-Since"
→ when (timeStamp > lastTime)
$ abort
$ mkAbortion' PreconditionFailed
- $ "The entity has not been modified since " ⊕ A.toText str
+ $ "The entity has not been modified since " ⊕ cs str
Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
+ $ "Malformed If-Unmodified-Since: " ⊕ cs str
Nothing → return ()
driftTo ReceivingBody
(bsToAscii =≪ getChunks limit)
bsToAscii bs
- = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
- Just a → return a
- Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
+ = case convertAttemptVia ((⊥) ∷ ByteString) bs of
+ Success a → return a
+ Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
readMultipartFormData m
= case lookup "boundary" m of
→ 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
+ b ← case ca boundary of
+ Success b → return b
+ Failure _ → abort $ mkAbortion' BadRequest
+ $ "Malformed boundary: " ⊕ boundary
case parseMultipartFormData b src of
- Right xs → return $ map (first A.toByteString) xs
+ Right xs → return $ map (first cs) xs
Left err → abort $ mkAbortion' BadRequest $ T.pack err
-- |@'redirect' code uri@ declares the response status as @code@ and
= do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
$ abort
$ mkAbortion' InternalServerError
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "Attempted to redirect with status "
- ⊕ printStatusCode sc
+ $ cs
+ $ ("Attempted to redirect with status " ∷ Ascii)
+ ⊕ cs (fromStatusCode sc)
setStatus sc
setLocation uri
projects / Lucu.git / blobdiff