, QuasiQuotes
, RecordWildCards
, UnicodeSyntax
+ , ViewPatterns
#-}
-- |This is the Resource Monad; monadic actions to define a behavior
-- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
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 Data.Time.Format.HTTP
import Network.HTTP.Lucu.Abortion
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.Response.StatusCode
+import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
Nothing
→ return []
Just accept
- → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of
+ → case P.parseOnly (finishOff def) (cs accept) of
Right xs → return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ cs accept
-- identity のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly (finishOff acceptEncodingList) (cs 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: " ⊕ cs ae
Nothing
→ return Nothing
Just cType
- → case P.parseOnly (finishOff MT.mimeType) (cs cType) of
+ → case P.parseOnly (finishOff def) (cs cType) of
Right t → return $ Just t
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Content-Type: " ⊕ cs cType
Nothing
→ return Nothing
Just auth
- → case P.parseOnly (finishOff authCredential) (cs 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"
- $ flip proxy http
- $ cs timeStamp
+ $ formatUTCTime timeStamp
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
→ if value ≡ "*" then
return ()
else
- case P.parseOnly (finishOff eTagList) (cs value) of
+ case P.parseOnly (finishOff def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-Match"
Right tags
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
abort $ mkAbortion' statusForNoneMatch
$ "The entity tag matches: *"
else
- case P.parseOnly (finishOff eTagList) (cs 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
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "Last-Modified"
- $ flip proxy http
- $ cs timeStamp
+ $ formatUTCTime timeStamp
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
ifModSince ← getHeader "If-Modified-Since"
case ifModSince of
- Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just str → case untag' <$> (fromAttempt $ ca str) of
Just lastTime
→ when (timeStamp ≤ lastTime)
$ abort
ifUnmodSince ← getHeader "If-Unmodified-Since"
case ifUnmodSince of
- Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just str → case untag' <$> (fromAttempt $ ca str) of
Just lastTime
→ when (timeStamp > lastTime)
$ abort
Nothing → return ()
driftTo ReceivingBody
+ where
+ untag' ∷ Tagged HTTP α → α
+ {-# INLINE untag' #-}
+ untag' = untag
-- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
-- entity for the request URI. @mStr@ is an optional error message to
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
$ "Malformed boundary: " ⊕ boundary
case parseMultipartFormData b src of
Right xs → return $ map (first cs) xs
- Left err → abort $ mkAbortion' BadRequest $ T.pack err
+ 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
-- 'isRedirection' or it raises an error.
redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
-redirect sc uri
- = do when (sc â\89\88 NotModified ∨ (¬) (isRedirection sc))
+redirect (fromStatusCode → sc) uri
+ = do when (sc â\89¡ cs NotModified ∨ (¬) (isRedirection sc))
$ abort
$ mkAbortion' InternalServerError
$ cs
$ ("Attempted to redirect with status " ∷ Ascii)
- ⊕ cs (fromStatusCode sc)
+ ⊕ cs sc
setStatus sc
setLocation uri