= do wroteHeader <- readTVar (itrWroteHeader itr)
-- Content-Type が正しくなければ補完できない。
- res <- readTVar (itrResponse itr)
+ res <- readItr itr itrResponse id
when (getHeader "Content-Type" res == Just defaultPageContentType)
- $ do let reqM = itrRequest itr
- conf = itrConfig itr
+ $ do reqM <- readItr itr itrRequest id
+
+ let conf = itrConfig itr
page = B.pack $ getDefaultPage conf reqM res
writeTVar (itrBodyToSend itr)
itrConfig :: Config
, itrRemoteHost :: HostName
, itrResourcePath :: Maybe [String]
- , itrRequest :: Maybe Request
+ , itrRequest :: TVar (Maybe Request)
, itrResponse :: TVar Response
-- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
newInteraction conf host req
- = do responce <- newTVarIO $ Response {
+ = do request <- newTVarIO $ req
+ responce <- newTVarIO $ Response {
resVersion = HttpVersion 1 1
, resStatus = Ok
, resHeaders = [("Content-Type", defaultPageContentType)]
itrConfig = conf
, itrRemoteHost = host
, itrResourcePath = Nothing
- , itrRequest = req
+ , itrRequest = request
, itrResponse = responce
, itrRequestHasBody = requestHasBody
postprocess :: Interaction -> STM ()
postprocess itr
- = do res <- readItr itr itrResponse id
+ = do reqM <- readItr itr itrRequest id
+ res <- readItr itr itrResponse id
let sc = resStatus res
when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
$ abortSTM InternalServerError []
$ Just ("The status code was " ++ show sc ++ " but no Location header.")
- when (itrRequest itr /= Nothing)
+ when (reqM /= Nothing)
$ relyOnRequest itr
-- itrResponse の内容は relyOnRequest によって變へられてゐる可
relyOnRequest :: Interaction -> STM ()
relyOnRequest itr
= do status <- readItr itr itrResponse resStatus
+ req <- readItr itr itrRequest fromJust
- let req = fromJust $ itrRequest itr
- reqVer = reqVersion req
+ let reqVer = reqVersion req
canHaveBody = if reqMethod req == HEAD then
False
else
import Control.Monad
import Data.Char
import Data.Maybe
+import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
+import Network
import Network.URI
{-
+ * URI にホスト名が存在しない時、
+ [1] HTTP/1.0 ならば Config を使って補完
+ [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
+
* Expect: に問題があった場合は 417 Expectation Failed に設定。
100-continue 以外のものは全部 417 に。
体的には、identity でも chunked でもなければ 501 Not Implemented に
する。
- * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
- 場合には 400 Bad Request にする。
-
* メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
Not Implemented にする。
preprocess :: Interaction -> STM ()
preprocess itr
- = do let req = fromJust $ itrRequest itr
- reqVer = reqVersion req
+ = do req <- readItr itr itrRequest fromJust
+
+ let reqVer = reqVersion req
if reqVer /= HttpVersion 1 0 &&
reqVer /= HttpVersion 1 1 then
- do setStatus itr HttpVersionNotSupported
+ do setStatus HttpVersionNotSupported
writeItr itr itrWillClose True
else
- do if reqVer == HttpVersion 1 0 then
- -- HTTP/1.0 では Keep-Alive できない
- writeItr itr itrWillClose True
- else
- -- URI または Host: ヘッダのどちらかにホストが無ければ
- -- ならない。
- when (uriAuthority (reqURI req) == Nothing &&
- getHeader "Host" req == Nothing)
- $ setStatus itr BadRequest
+ -- HTTP/1.0 では Keep-Alive できない
+ do when (reqVer == HttpVersion 1 0)
+ $ writeItr itr itrWillClose True
+
+ -- ホスト部の補完
+ completeAuthority req
case reqMethod req of
GET -> return ()
HEAD -> writeItr itr itrWillDiscardBody True
POST -> writeItr itr itrRequestHasBody True
PUT -> writeItr itr itrRequestHasBody True
- _ -> setStatus itr NotImplemented
+ _ -> setStatus NotImplemented
mapM_ (preprocessHeader itr) (reqHeaders req)
where
- setStatus itr status
+ setStatus :: StatusCode -> STM ()
+ setStatus status
= updateItr itr itrResponse
$ \ res -> res {
resStatus = status
}
+ completeAuthority :: Request -> STM ()
+ completeAuthority req
+ = when (uriAuthority (reqURI req) == Nothing)
+ $ if reqVersion req == HttpVersion 1 0 then
+ -- HTTP/1.0 なので Config から補完
+ do let conf = itrConfig itr
+ host = cnfServerHost conf
+ port = case cnfServerPort conf of
+ PortNumber n -> Just $ fromIntegral n
+ _ -> Nothing
+ portStr
+ = case port of
+ Just 80 -> Just ""
+ Just n -> Just $ ":" ++ show n
+ Nothing -> Nothing
+ case portStr of
+ Just str -> updateAuthority host str
+ -- FIXME: このエラーの原因は、listen してゐるソ
+ -- ケットが INET でない故にポート番號が分からな
+ -- い事だが、その事をどうにかして通知した方が良
+ -- いと思ふ。stderr？
+ Nothing -> setStatus InternalServerError
+ else
+ do case getHeader "Host" req of
+ Just str -> let (host, portStr) = parseHost str
+ in updateAuthority host portStr
+ Nothing -> setStatus BadRequest
+
+
+ parseHost :: String -> (String, String)
+ parseHost = break (== ':')
+
+
+ updateAuthority :: String -> String -> STM ()
+ updateAuthority host portStr
+ = updateItr itr itrRequest
+ $ \ (Just req) -> Just req {
+ reqURI = let uri = reqURI req
+ in uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = host
+ , uriPort = portStr
+ }
+ }
+ }
+
+
preprocessHeader itr (name, value)
= case map toLower name of
-> if value `noCaseEq` "100-continue" then
writeItr itr itrExpectedContinue True
else
- setStatus itr ExpectationFailed
+ setStatus ExpectationFailed
"transfer-encoding"
-> case map toLower value of
"identity" -> return ()
"chunked" -> writeItr itr itrRequestIsChunked True
- _ -> setStatus itr NotImplemented
+ _ -> setStatus NotImplemented
"content-length"
-> if all isDigit value then
writeItr itr itrReqChunkLength $ Just len
writeItr itr itrReqChunkRemaining $ Just len
else
- setStatus itr BadRequest
+ setStatus BadRequest
"connection"
-> case map toLower value of
if isErr then
acceptSemanticallyInvalidRequest itr input
else
- case findResource tree $ (reqURI . fromJust . itrRequest) itr of
+ case findResource tree $ reqURI req of
Nothing -- Resource が無かった
-> acceptRequestForNonexistentResource itr input
, setHeader
, redirect
, setContentType
+ , setLocation
-- ** Writing a response body
-- the request header. In general you don't have to use this action.
getRequest :: Resource Request
getRequest = do itr <- ask
- return $ fromJust $ itrRequest itr
+ req <- liftIO $ atomically $ readItr itr itrRequest fromJust
+ return req
-- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
getMethod :: Resource Method
-- so frequently: there should be actions like 'getContentType' for
-- every common headers.
getHeader :: String -> Resource (Maybe String)
-getHeader name = do itr <- ask
- return $ H.getHeader name $ fromJust $ itrRequest itr
+getHeader name = do req <- getRequest
+ return $ H.getHeader name req
-- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
-- header \"Accept\".
--
-- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
-- test and aborts with status \"412 Precondition Failed\" when it
--- failed. If this is a GET, HEAD or DELETE request, 'foundNoEntity'
--- always aborts with status \"404 Not Found\". It is an error to
--- compute 'foundNoEntity' if this is a POST request.
+-- failed. If this is a GET, HEAD, POST or DELETE request,
+-- 'foundNoEntity' always aborts with status \"404 Not Found\".
foundNoEntity :: Maybe String -> Resource ()
foundNoEntity msgM
= do driftTo ExaminingRequest
method <- getMethod
- when (method == POST)
- $ abort InternalServerError []
- (Just "Illegal computation of foundNoEntity for POST request.")
when (method /= PUT)
$ abort NotFound [] msgM
$ abort InternalServerError []
$ Just ("Attempted to redirect with status " ++ show code)
setStatus code
- setHeader "Location" (uriToString id uri $ "")
+ setLocation uri
-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType mType
= setHeader "Content-Type" $ show mType
+-- | Computation of @'setLocation' uri@ sets the response header
+-- \"Location\" to @uri@.
+setLocation :: URI -> Resource ()
+setLocation uri
+ = setHeader "Location" $ uriToString id uri $ ""
+
{- DecidingBody 時に使用するアクション群 -}
runResource :: ResourceDef -> Interaction -> IO ThreadId
runResource def itr
= fork
- $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
+ $ catch ( runReaderT ( do req <- getRequest
+ fromMaybe notAllowed $ rsrc req
driftTo Done
) itr
)
then forkOS
else forkIO
- 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
+ rsrc :: Request -> Maybe (Resource ())
+ rsrc req
+ = case reqMethod req 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
$ Just $ show exc
_ -> Abortion InternalServerError [] $ Just $ show exc
conf = itrConfig itr
- reqM = itrRequest itr
-- まだ DecidingHeader 以前の状態だったら、この途中終了
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
state <- atomically $ readItr itr itrState id
+ reqM <- atomically $ readItr itr itrRequest id
res <- atomically $ readItr itr itrResponse id
if state <= DecidingHeader then
flip runReaderT itr
projects / Lucu.git / commitdiff