- rsrc :: Maybe (Resource ())
- rsrc = case reqMethod $ fromJust $ itrRequest itr of
- GET -> resGet def
- HEAD -> case resHead def of
- Just r -> Just r
- Nothing -> resGet def
- POST -> resPost def
- PUT -> resPut def
- DELETE -> resDelete def
-
- notAllowed :: Resource ()
- notAllowed = do setStatus MethodNotAllowed
- setHeader "Allow" $ joinWith ", " allowedMethods
-
- allowedMethods :: [String]
- allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
- , methods resHead ["GET", "HEAD"]
- , methods resPost ["POST"]
- , methods resPut ["PUT"]
- , methods resDelete ["DELETE"]
- ]
-
- methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
- methods f xs = case f def of
- Just _ -> xs
- Nothing -> []
-
- processException :: Config -> Exception -> IO ()
- processException conf exc
- = do let abo = case exc of
- ErrorCall msg -> Abortion InternalServerError [] msg
- IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE
- DynException dynE -> case fromDynamic dynE of
- Just (abo :: Abortion) -> abo
- Nothing
- -> Abortion InternalServerError []
- $ show exc
- _ -> Abortion InternalServerError [] $ show exc
- -- まだ DecidingHeader 以前の状態だったら、この途中終了
- -- を應答に反映させる餘地がある。さうでなければ stderr
- -- にでも吐くしか無い。
- state <- atomically $ readItr itr itrState id
- if state <= DecidingHeader then
- flip runReaderT itr
- $ do setStatus $ aboStatus abo
- -- FIXME: 同じ名前で複數の値があった時は、こ
- -- れではまずいと思ふ。
- mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
- setHeader "Content-Type" "application/xhtml+xml"
- output $ aboPage conf abo
- else
- hPutStrLn stderr $ show abo
-
- flip runReaderT itr $ driftTo Done
-
- formatIOE :: IOError -> String
- formatIOE ioE = if isUserError ioE then
- ioeGetErrorString ioE
- else
- show ioE
-
-
-{- Resource モナド -}
-
-input :: Int -> Resource String
-input limit = inputBS limit >>= return . B.unpack
-
-
--- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
--- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
-inputBS :: Int -> Resource ByteString
-inputBS limit
- = do driftTo GettingBody
- itr <- ask
- let defaultLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit <= 0 then
- defaultLimit
- else
- limit
- when (actualLimit <= 0)
- $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
- -- Reader にリクエスト
- liftIO $ atomically
- $ do chunkLen <- readItr itr itrReqChunkLength id
- writeItr itr itrWillReceiveBody True
- if fmap (> actualLimit) chunkLen == Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeItr itr itrReqBodyWanted $ Just actualLimit
- -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk <- liftIO $ atomically
- $ do chunk <- readItr itr itrReceivedBody id
- chunkIsOver <- readItr itr itrReqChunkIsOver id
- if B.length chunk < fromIntegral actualLimit then
- -- 要求された量に滿たなくて、まだ殘りがある
- -- なら再試行。
- unless chunkIsOver
- $ retry
- else
- -- 制限値一杯まで讀むやうに指示したのにまだ殘っ
- -- てゐるなら、それは多過ぎる。
- unless chunkIsOver
- $ tooLarge actualLimit
- -- 成功。itr 内にチャンクを置いたままにするとメ
- -- モリの無駄になるので除去。
- writeItr itr itrReceivedBody B.empty
- return chunk
- driftTo DecidingHeader
- return chunk
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "ETag"
+ $ A.fromAsciiBuilder
+ $ printETag tag
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "Illegal computation of foundETag for POST request."
+
+ -- If-Match があればそれを見る。
+ ifMatch ← getHeader "If-Match"
+ case ifMatch of
+ Nothing → return ()
+ Just value → if value ≡ "*" then
+ return ()
+ else
+ case P.parseOnly p (A.toByteString value) of
+ Right tags
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ → when ((¬) (any (≡ tag) tags))
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity tag doesn't match: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-Match: " ⊕ A.toText value
+
+ let statusForNoneMatch
+ = if method ≡ GET ∨ method ≡ HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- If-None-Match があればそれを見る。
+ ifNoneMatch ← getHeader "If-None-Match"
+ case ifNoneMatch of
+ Nothing → return ()
+ Just value → if value ≡ "*" then
+ abort $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: *"
+ else
+ case P.parseOnly p (A.toByteString value) of
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort
+ $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-None-Match: " ⊕ A.toText value
+
+ driftTo ReceivingBody
+ where
+ p = do xs ← eTagListP
+ P.endOfInput
+ return xs
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
+-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
+-- \"If-None-Match\" test. Be aware that any tests based on a last
+-- modification time are unsafe because it is possible to mess up such
+-- tests by modifying the entity twice in a second.
+--
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.
+foundTimeStamp ∷ UTCTime → Resource ()
+foundTimeStamp timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "Illegal computation of foundTimeStamp for POST request."
+
+ let statusForIfModSince
+ = if method ≡ GET ∨ method ≡ HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- If-Modified-Since があればそれを見る。
+ ifModSince ← getHeader "If-Modified-Since"
+ case ifModSince of
+ Just str → case HTTP.fromAscii str of
+ Right lastTime
+ → when (timeStamp ≤ lastTime)
+ $ abort
+ $ mkAbortion' statusForIfModSince
+ $ "The entity has not been modified since " ⊕ A.toText str
+ Left _
+ → return () -- 不正な時刻は無視
+ Nothing → return ()
+
+ -- If-Unmodified-Since があればそれを見る。
+ ifUnmodSince ← getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ Just str → case HTTP.fromAscii str of
+ Right lastTime
+ → when (timeStamp > lastTime)
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity has not been modified since " ⊕ A.toText str
+ Left _
+ → return () -- 不正な時刻は無視
+ Nothing → return ()
+
+ driftTo ReceivingBody
+
+-- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
+-- no entity for the request URI. @mStr@ is an optional error message
+-- to be replied to the client.
+--
+-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
+-- test and when that fails it aborts with status \"412 Precondition
+-- Failed\". If the request method is GET, HEAD, POST or DELETE,
+-- 'foundNoEntity' always aborts with status \"404 Not Found\".
+foundNoEntity ∷ Maybe Text → Resource ()
+foundNoEntity msgM
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≢ PUT)
+ $ abort
+ $ mkAbortion NotFound [] msgM
+
+ -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+ -- If-Match: 條件も滿たさない。
+ ifMatch ← getHeader "If-Match"
+ when (ifMatch ≢ Nothing)
+ $ abort
+ $ mkAbortion PreconditionFailed [] msgM
+
+ driftTo ReceivingBody
+
+-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
+foundNoEntity' ∷ Resource ()
+{-# INLINE foundNoEntity' #-}
+foundNoEntity' = foundNoEntity Nothing
+
+
+-- |@'getChunks' limit@ attemts to read the entire request body up to
+-- @limit@ bytes, and then make the 'Resource' transit to the
+-- /Deciding Header/ state. When the actual size of the body is larger
+-- than @limit@ bytes, 'getChunks' immediately aborts with status
+-- \"413 Request Entity Too Large\". When the request has no body, it
+-- returns an empty string.
+--
+-- When the @limit@ is 'Nothing', 'getChunks' uses the default
+-- limitation value ('cnfMaxEntityLength') instead.
+--
+-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
+-- lazy: reading from the socket just happens at the computation of
+-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
+getChunks ∷ Maybe Int → Resource Lazy.ByteString
+getChunks (Just n)
+ | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
+ | n ≡ 0 = return (∅)
+ | otherwise = getChunks' n
+getChunks Nothing
+ = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
+
+getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' limit = go limit (∅)
+ where
+ go ∷ Int → Builder → Resource Lazy.ByteString
+ 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 !b = do c ← getChunk $ min n BB.defaultBufferSize
+ if Strict.null c then
+ -- Got EOF
+ return $ BB.toLazyByteString b
+ else
+ do let n' = n - Strict.length c
+ xs' = b ⊕ BB.fromByteString c
+ go n' xs'
+
+-- |@'getForm' limit@ attempts to read the request body with
+-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
+-- @multipart\/form-data@. If the request header \"Content-Type\" is
+-- neither of them, 'getForm' aborts with status \"415 Unsupported
+-- Media Type\". If the request has no \"Content-Type\", it aborts
+-- with \"400 Bad Request\".
+--
+-- Field names in @multipart\/form-data@ will be precisely decoded in
+-- accordance with RFC 2231. On the other hand,
+-- @application\/x-www-form-urlencoded@ says nothing about character
+-- encodings for field names, so they'll always be decoded in
+-- UTF-8. (This could be a bad design, but I can't think of any better
+-- idea.)
+getForm ∷ Maybe Int → Resource [(Text, FormData)]
+getForm limit
+ = do cTypeM ← getContentType
+ case cTypeM of
+ Nothing
+ → 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 $ mkAbortion' UnsupportedMediaType
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Unsupported media type: "
+ ⊕ printMIMEType cType