{-# LANGUAGE
CPP
, BangPatterns
+ , FlexibleContexts
, GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
(
-- * Types
Resource(..)
- , emptyResource
, Rsrc
, FormData(..)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt
import qualified Data.Attoparsec.Char8 as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
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.Default
import Data.List (intersperse, sort)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
+import Data.Proxy
+import Data.Tagged
import Data.Text (Text)
-import qualified Data.Text as T
import Data.Time
-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Authentication
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.MIMEType (MIMEType(..))
-import qualified Network.HTTP.Lucu.MIMEType as MT
-import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
getRequestVersion = reqVersion <$> getRequest
-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
--- @[]@ if the corresponding
--- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See:
--- 'getResourcePath'
+-- @[]@ if the corresponding 'Resource' is not greedy. See
+-- 'getResourcePath'.
--
-- Note that the returned path components are URI-decoded.
getPathInfo ∷ Rsrc [Strict.ByteString]
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 def) (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 def) (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 def) (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 def) (cs auth) of
Right ac → return $ Just ac
Left _ → return Nothing
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
- $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ $ setHeader "Last-Modified"
+ $ flip proxy http
+ $ cs timeStamp
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "ETag"
- $ A.fromAsciiBuilder
- $ printETag tag
+ $ cs tag
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
→ if value ≡ "*" then
return ()
else
- case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ case P.parseOnly (finishOff def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-Match"
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 def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-None-Match"
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
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
- $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ $ setHeader "Last-Modified"
+ $ flip proxy http
+ $ cs timeStamp
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
ifModSince ← getHeader "If-Modified-Since"
case ifModSince of
- Just str → case HTTP.fromAscii str of
- Right lastTime
+ Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just lastTime
→ when (timeStamp ≤ lastTime)
$ abort
$ mkAbortion' statusForIfModSince
- $ "The entity has not been modified since " ⊕ A.toText str
- Left e
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Modified-Since: " ⊕ T.pack e
+ $ "Malformed If-Modified-Since: " ⊕ cs str
Nothing → return ()
ifUnmodSince ← getHeader "If-Unmodified-Since"
case ifUnmodSince of
- Just str → case HTTP.fromAscii str of
- Right lastTime
+ Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just lastTime
→ when (timeStamp > lastTime)
$ abort
$ mkAbortion' PreconditionFailed
- $ "The entity has not been modified since " ⊕ A.toText str
- Left e
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
+ $ "Malformed If-Unmodified-Since: " ⊕ cs str
Nothing → return ()
driftTo ReceivingBody
else
abort $ mkAbortion' RequestEntityTooLarge
$ "Request body must be smaller than "
- ⊕ T.pack (show limit)
+ ⊕ cs (show limit)
⊕ " bytes."
go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
if Strict.null c then
→ readMultipartFormData params
Just cType
→ abort $ mkAbortion' UnsupportedMediaType
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "Unsupported media type: "
- ⊕ MT.printMIMEType cType
+ $ cs
+ $ ("Unsupported media type: " ∷ Ascii)
+ ⊕ cs cType
where
readWWWFormURLEncoded
= (map toPairWithFormData ∘ parseWWWFormURLEncoded)
(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
- Left err → abort $ mkAbortion' BadRequest $ T.pack err
+ Right xs → return $ map (first cs) xs
+ Left err → abort $ mkAbortion' BadRequest $ cs err
-- |@'redirect' code uri@ declares the response status as @code@ and
-- \"Location\" header field as @uri@. The @code@ must satisfy
= 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
-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
-- mandatory for sending a response body.
setContentType ∷ MIMEType → Rsrc ()
-setContentType
- = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
+setContentType = setHeader "Content-Type" ∘ cs
-- |@'setLocation' uri@ declares the response header \"Location\" as
-- @uri@. You usually don't need to call this function directly.
setLocation ∷ URI → Rsrc ()
setLocation uri
- = case A.fromChars uriStr of
- Just a → setHeader "Location" a
- Nothing → abort $ mkAbortion' InternalServerError
- $ "Malformed URI: " ⊕ T.pack uriStr
+ = case ca uriStr of
+ Success a → setHeader "Location" a
+ Failure e → abort $ mkAbortion' InternalServerError
+ $ cs (show e)
where
uriStr = uriToString id uri ""
_ → abort $ mkAbortion' InternalServerError
"setContentEncoding: Unknown HTTP version"
setHeader "Content-Encoding"
- $ A.fromAsciiBuilder
+ $ cs
$ mconcat
- $ intersperse (A.toAsciiBuilder ", ")
+ $ intersperse (cs (", " ∷ Ascii))
$ map tr codings
where
- toAB = A.toAsciiBuilder ∘ A.fromCIAscii
+ toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
+ toAB = cs
-- |@'setWWWAuthenticate' challenge@ declares the response header
-- \"WWW-Authenticate\" as @challenge@.
setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
-setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
-- |Write a chunk in 'Strict.ByteString' to the response body. You
-- must first declare the response header \"Content-Type\" before
--- applying this function. See: 'setContentType'
+-- applying this function. See 'setContentType'.
putChunk ∷ Strict.ByteString → Rsrc ()
putChunk = putBuilder ∘ BB.fromByteString
-- 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:
--- 'setContentType'
+-- \"Content-Type\" before applying this function. See
+-- 'setContentType'.
putChunks ∷ Lazy.ByteString → Rsrc ()
putChunks = putBuilder ∘ BB.fromLazyByteString
projects / Lucu.git / blobdiff