import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
+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.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
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]
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
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "ETag"
$ A.fromAsciiBuilder
- $ printETag tag
+ $ cs tag
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
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
+ Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Modified-Since: " ⊕ T.pack e
+ $ "Malformed If-Modified-Since: " ⊕ A.toText 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
+ Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
+ $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
Nothing → return ()
driftTo ReceivingBody
→ 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)
-- \"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.
-- |@'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