module Network.HTTP.Lucu.Abortion
( Abortion(..)
- , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
- , abortSTM -- StatusCode -> [ (String, String) ] -> Maybe String -> STM a
- , abortA -- ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
- , abortPage -- Config -> Maybe Request -> Maybe Response -> Abortion -> String
+ , abort
+ , abortSTM
+ , abortA
+ , abortPage
)
where
-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
--- ければならない。しかもその時は resM から Response を捏造までする必要
--- がある。
-abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String
-abortPage conf reqM resM abo
+-- ければならない。
+abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
+abortPage conf reqM res abo
= case aboMessage abo of
Just msg
-> let [html] = unsafePerformIO
in
html
Nothing
- -> let res' = case resM of
- Just res -> res { resStatus = aboStatus abo }
- Nothing -> Response {
- resVersion = HttpVersion 1 1
- , resStatus = aboStatus abo
- , resHeaders = []
- }
- res = foldl (.) id [setHeader name value
- | (name, value) <- aboHeaders abo]
- $ res'
+ -> let res' = res { resStatus = aboStatus abo }
+ res'' = foldl (.) id [setHeader name value
+ | (name, value) <- aboHeaders abo]
+ $ res'
in
- getDefaultPage conf reqM res
+ getDefaultPage conf reqM res''
writeDefaultPage itr
= do wroteHeader <- readTVar (itrWroteHeader itr)
- -- ヘッダが出力濟だったら意味が無い。
- when wroteHeader
- $ fail "writeDefaultPage: the header has already been written"
-
- resM <- readTVar (itrResponse itr)
-
- -- Response が不明ならばページ書込も不可
- when (resM == Nothing)
- $ fail "writeDefaultPage: response was Nothing"
-
- let reqM = itrRequest itr
- res = fromJust resM
- conf = itrConfig itr
- page = B.pack $ getDefaultPage conf reqM res
-
- writeTVar (itrResponse itr)
- $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
-
- writeTVar (itrBodyToSend itr)
- $ page
+ -- Content-Type が正しくなければ補完できない。
+ res <- readTVar (itrResponse itr)
+ when (getHeader "Content-Type" res == Just defaultPageContentType)
+ $ do let reqM = itrRequest itr
+ conf = itrConfig itr
+ page = B.pack $ getDefaultPage conf reqM res
+
+ writeTVar (itrBodyToSend itr)
+ $ page
mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
( Interaction(..)
, InteractionState(..)
, InteractionQueue
- , newInteractionQueue -- IO InteractionQueue
- , newInteraction -- Config -> HostName -> Maybe Request -> IO Interaction
-
- , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
- , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
- , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
- , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
- , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+ , newInteractionQueue
+ , newInteraction
+ , defaultPageContentType
+
+ , writeItr
+ , readItr
+ , readItrF
+ , updateItr
+ , updateItrF
)
where
import Data.Sequence (Seq)
import Network
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
, itrRemoteHost :: HostName
, itrResourcePath :: Maybe [String]
, itrRequest :: Maybe Request
- , itrResponse :: TVar (Maybe Response)
+ , itrResponse :: TVar Response
-- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
-- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
newInteractionQueue = newTVarIO S.empty
+defaultPageContentType :: String
+defaultPageContentType = "application/xhtml+xml"
+
+
newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
newInteraction conf host req
- = do responce <- newTVarIO Nothing
+ = do responce <- newTVarIO $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Ok
+ , resHeaders = [("Content-Type", defaultPageContentType)]
+ }
requestHasBody <- newTVarIO False
requestIsChunked <- newTVarIO False
* HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
Error にする。但し identity だけは許す。
- * body を持つ事が出來る時、Content-Type が無ければ
- application/octet-stream にする。出來ない時、HEAD でなければ
- Content-Type, Etag, Last-Modified を削除する。
+ * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
+ 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
+ する。
* body を持つ事が出來ない時、body 破棄フラグを立てる。
postprocess :: Interaction -> STM ()
postprocess itr
- = do resM <- readItr itr itrResponse id
-
- case resM of
- Nothing -> writeItr itr itrResponse
- $ Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = Ok
- , resHeaders = []
- }
- Just res -> do let sc = resStatus res
-
- when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
- $ abortSTM InternalServerError []
- $ Just ("The status code is not good for a final status: "
- ++ show sc)
-
- when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
- $ abortSTM InternalServerError []
- $ Just ("The status was " ++ show sc ++ " but no Allow header.")
-
- when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
- $ abortSTM InternalServerError []
- $ Just ("The status code was " ++ show sc ++ " but no Location header.")
+ = do res <- readItr itr itrResponse id
+ let sc = resStatus res
+
+ when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
+ $ abortSTM InternalServerError []
+ $ Just ("The status code is not good for a final status: "
+ ++ show sc)
+
+ when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
+ $ abortSTM InternalServerError []
+ $ Just ("The status was " ++ show sc ++ " but no Allow header.")
+
+ when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
+ $ abortSTM InternalServerError []
+ $ Just ("The status code was " ++ show sc ++ " but no Location header.")
when (itrRequest itr /= Nothing)
$ relyOnRequest itr
- do oldRes <- readItr itr itrResponse id
- newRes <- unsafeIOToSTM
- $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes)
- writeItr itr itrResponse $ Just newRes
+ do newRes <- unsafeIOToSTM
+ $ completeUnconditionalHeaders (itrConfig itr) res
+ writeItr itr itrResponse newRes
where
relyOnRequest :: Interaction -> STM ()
relyOnRequest itr
- = do status <- readItr itr itrResponse (resStatus . fromJust)
+ = do status <- readItr itr itrResponse resStatus
let req = fromJust $ itrRequest itr
reqVer = reqVersion req
cType <- readHeader itr "Content-Type"
when (cType == Nothing)
- $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
+ $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
if canHaveBody then
do teM <- readHeader itr "Transfer-Encoding"
readHeader :: Interaction -> String -> STM (Maybe String)
readHeader itr name
- = do valueMM <- readItrF itr itrResponse $ getHeader name
- case valueMM of
- Just (Just val) -> return $ Just val
- _ -> return Nothing
+ = readItr itr itrResponse $ getHeader name
updateRes :: Interaction -> (Response -> Response) -> STM ()
updateRes itr updator
- = updateItrF itr itrResponse updator
+ = updateItr itr itrResponse updator
completeUnconditionalHeaders :: Config -> Response -> IO Response
mapM_ (preprocessHeader itr) (reqHeaders req)
where
setStatus itr status
- = writeItr itr itrResponse $ Just (Response {
- resVersion = HttpVersion 1 1
- , resStatus = status
- , resHeaders = []
- })
+ = updateItr itr itrResponse
+ $ \ res -> res {
+ resStatus = status
+ }
preprocessHeader itr (name, value)
= case map toLower name of
acceptNonparsableRequest :: StatusCode -> IO ()
acceptNonparsableRequest status
= do itr <- newInteraction cnf host Nothing
- let res = Response {
- resVersion = HttpVersion 1 1
- , resStatus = status
- , resHeaders = []
- }
- atomically $ do writeItr itr itrResponse $ Just res
+ atomically $ do updateItr itr itrResponse
+ $ \ res -> res {
+ resStatus = status
+ }
writeItr itr itrWillClose True
writeItr itr itrState Done
writeDefaultPage itr
action
<- atomically $
do preprocess itr
- isErr <- readItrF itr itrResponse (isError . resStatus)
- if isErr == Just True then
+ isErr <- readItr itr itrResponse (isError . resStatus)
+ if isErr then
acceptSemanticallyInvalidRequest itr input
else
case findResource tree $ (reqURI . fromJust . itrRequest) itr of
acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
acceptRequestForNonexistentResource itr input
- = do let res = Response {
- resVersion = HttpVersion 1 1
- , resStatus = NotFound
- , resHeaders = []
- }
- writeItr itr itrResponse $ Just res
+ = do updateItr itr itrResponse
+ $ \res -> res {
+ resStatus = NotFound
+ }
writeItr itr itrState Done
writeDefaultPage itr
postprocess itr
chunkWasMalformed :: Interaction -> IO ()
chunkWasMalformed itr
- = let res = Response {
- resVersion = HttpVersion 1 1
- , resStatus = BadRequest
- , resHeaders = []
- }
- in
- atomically $ do writeItr itr itrResponse $ Just res
- writeItr itr itrWillClose True
- writeItr itr itrState Done
- writeDefaultPage itr
- postprocess itr
+ = atomically $ do updateItr itr itrResponse
+ $ \ res -> res {
+ resStatus = BadRequest
+ }
+ writeItr itr itrWillClose True
+ writeItr itr itrState Done
+ writeDefaultPage itr
+ postprocess itr
observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
observeNonChunkedRequest itr input
+-- |This is the Resource Monad; monadic actions to define the behavior
+-- of each resources. The 'Resource' Monad is a kind of IO Monad thus
+-- it implements MonadIO class. It is also a state machine.
+--
+-- Request Processing Flow:
+--
+-- 1. A client issues an HTTP request.
+--
+-- 2. If the URI of it matches to any resource, the corresponding
+-- 'Resource' Monad starts running on a newly spawned thread.
+--
+-- 3. The 'Resource' Monad looks at the request header, find (or not
+-- find) an entity, receive the request body (if any), decide the
+-- response header, and decide the response body. This process
+-- will be discussed later.
+--
+-- 4. The 'Resource' Monad and its thread stops running. The client
+-- may or may not be sending us the next request at this point.
+--
+-- 'Resource' Monad is composed of the following states. The initial
+-- state is /Examining Request/ and the final state is /Done/.
+--
+-- [/Examining Request/] In this state, a 'Resource' looks at the
+-- request header and thinks about an entity for it. If there is a
+-- suitable entity, the 'Resource' tells the system an entity tag
+-- and its last modification time ('foundEntity'). If it found no
+-- entity, it tells the system so ('foundNoEntity'). In case it is
+-- impossible to decide the existence of entity, which is a typical
+-- case for POST requests, 'Resource' does nothing in this state.
+--
+-- [/Getting Body/] A 'Resource' asks the system to receive a
+-- request body from client. Before actually reading from the
+-- socket, the system sends \"100 Continue\" to the client if need
+-- be. When a 'Resource' transits to the next state without
+-- receiving all or part of request body, the system still reads it
+-- and just throws it away.
+--
+-- [/Deciding Header/] A 'Resource' makes a decision of status code
+-- and response headers. When it transits to the next state, ...
+--
+-- [/Deciding Body/]
+--
+-- [/Done/]
+
+
+-- 一方通行であること、その理由
+
+-- FIXME: 續きを書く
+
module Network.HTTP.Lucu.Resource
( Resource
- , getConfig -- Resource Config
- , getRequest -- Resource Request
- , getMethod -- Resource Method
- , getRequestURI -- Resource URI
- , getResourcePath -- Resource [String]
- , getPathInfo -- Resource [String]
-
- , getHeader -- String -> Resource (Maybe String)
- , getAccept -- Resource [MIMEType]
- , getContentType -- Resource (Maybe MIMEType)
-
- , foundEntity -- ETag -> ClockTime -> Resource ()
- , foundETag -- ETag -> Resource ()
- , foundTimeStamp -- ClockTime -> Resource ()
- , foundNoEntity -- Maybe String -> Resource ()
-
- , input -- Int -> Resource String
- , inputChunk -- Int -> Resource String
- , inputBS -- Int -> Resource ByteString
- , inputChunkBS -- Int -> Resource ByteString
- , inputForm -- Int -> Resource [(String, String)]
- , defaultLimit -- Int
-
- , setStatus -- StatusCode -> Resource ()
- , setHeader -- String -> String -> Resource ()
- , redirect -- StatusCode -> URI -> Resource ()
- , setETag -- ETag -> Resource ()
- , setLastModified -- ClockTime -> Resource ()
- , setContentType -- MIMEType -> Resource ()
-
- , output -- String -> Resource ()
- , outputChunk -- String -> Resource ()
- , outputBS -- ByteString -> Resource ()
- , outputChunkBS -- ByteString -> Resource ()
-
- , driftTo -- InteractionState -> Resource ()
+ , getConfig
+ , getRequest
+ , getMethod
+ , getRequestURI
+ , getResourcePath
+ , getPathInfo
+ , getHeader
+ , getAccept
+ , getContentType
+
+ , foundEntity
+ , foundETag
+ , foundTimeStamp
+ , foundNoEntity
+
+ , input
+ , inputChunk
+ , inputBS
+ , inputChunkBS
+ , inputForm
+ , defaultLimit
+
+ , setStatus
+ , setHeader
+ , redirect
+ , setETag
+ , setLastModified
+ , setContentType
+
+ , output
+ , outputChunk
+ , outputBS
+ , outputChunkBS
+
+ , driftTo
)
where
= do driftTo DecidingHeader
itr <- ask
liftIO $ atomically $ updateItr itr itrResponse
- $ \ resM -> case resM of
- Nothing -> Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = code
- , resHeaders = []
- }
- Just res -> Just $ res {
- resStatus = code
- }
+ $ \ res -> res {
+ resStatus = code
+ }
setHeader :: String -> String -> Resource ()
setHeader' :: String -> String -> Resource()
setHeader' name value
= do itr <- ask
- liftIO $ atomically $ updateItr itr itrResponse
- $ \ resM -> case resM of
- Nothing -> Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = Ok
- , resHeaders = [ (name, value) ]
- }
- Just res -> Just $ H.setHeader name value res
+ liftIO $ atomically
+ $ updateItr itr itrResponse
+ $ H.setHeader name value
redirect :: StatusCode -> URI -> Resource ()
[Done に遷移する時]
bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK
- だった場合は、補完の代はりに 204 No Content に變へる。
+ る。
-}
drift itr _ Done
= do bodyIsNull <- readItr itr itrBodyIsNull id
when bodyIsNull
- $ do status <- readStatus itr
- if status == Ok then
- do updateItrF itr itrResponse
- $ \ res -> res { resStatus = NoContent }
- updateItrF itr itrResponse
- $ H.deleteHeader "Content-Type"
- updateItrF itr itrResponse
- $ H.deleteHeader "ETag"
- updateItrF itr itrResponse
- $ H.deleteHeader "Last-Modified"
- else
- writeDefaultPage itr
-
+ $ writeDefaultPage itr
drift _ _ _
= return ()
-
-
- readStatus :: Interaction -> STM StatusCode
- readStatus itr = readItr itr itrResponse (resStatus . fromJust)
\ No newline at end of file
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
state <- atomically $ readItr itr itrState id
- resM <- atomically $ readItr itr itrResponse id
+ res <- atomically $ readItr itr itrResponse id
if state <= DecidingHeader then
flip runReaderT itr
$ do setStatus $ aboStatus abo
-- FIXME: 同じ名前で複數の値があった時は、こ
-- れではまずいと思ふ。
mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
- setContentType ("application" </> "xhtml+xml")
- output $ abortPage conf reqM resM abo
+ output $ abortPage conf reqM res abo
else
hPutStrLn stderr $ show abo
writeHeader itr
= do res <- atomically $ do writeItr itr itrWroteHeader True
readItr itr itrResponse id
- hPutResponse h (fromJust res)
+ hPutResponse h res
hFlush h
awaitSomethingToWrite
projects / Lucu.git / commitdiff