From e624f0db8c4610b36da9e4463a656e0cb8a104dd Mon Sep 17 00:00:00 2001 From: pho Date: Sun, 1 Apr 2007 17:49:10 +0900 Subject: [PATCH] Many improvements darcs-hash:20070401084910-62b54-fe8f2f925d889c87af4683f20e7fd17f9c84de09.gz --- Lucu.cabal | 4 +- Network/HTTP/Lucu/Abortion.hs | 67 ++++++ Network/HTTP/Lucu/Config.hs | 12 +- Network/HTTP/Lucu/DefaultPage.hs | 116 ++++++++-- Network/HTTP/Lucu/Interaction.hs | 84 ++++--- Network/HTTP/Lucu/Postprocess.hs | 82 +++++-- Network/HTTP/Lucu/Preprocess.hs | 4 +- Network/HTTP/Lucu/RequestReader.hs | 96 +++++++- Network/HTTP/Lucu/Resource.hs | 338 +++++++++++++++++++++++++++- Network/HTTP/Lucu/Response.hs | 22 +- Network/HTTP/Lucu/ResponseWriter.hs | 4 +- Network/HTTP/Lucu/Utils.hs | 9 + examples/HelloWorld.hs | 23 +- 13 files changed, 765 insertions(+), 96 deletions(-) create mode 100644 Network/HTTP/Lucu/Abortion.hs diff --git a/Lucu.cabal b/Lucu.cabal index 0667795..da7ecca 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -15,9 +15,9 @@ Exposed-Modules: Network.HTTP.Lucu.Response Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Request -ghc-options: -threaded +ghc-options: -threaded -fglasgow-exts Executable: HelloWorld Main-Is: HelloWorld.hs Hs-Source-Dirs: ., examples -ghc-options: -threaded \ No newline at end of file +ghc-options: -threaded -fglasgow-exts \ No newline at end of file diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs new file mode 100644 index 0000000..75ce437 --- /dev/null +++ b/Network/HTTP/Lucu/Abortion.hs @@ -0,0 +1,67 @@ +module Network.HTTP.Lucu.Abortion + ( Abortion(..) + , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a + , abortIO -- StatusCode -> [ (String, String) ] -> String -> IO a + , abortSTM -- StatusCode -> [ (String, String) ] -> String -> STM a + , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c + , aboPage -- Config -> Abortion -> String + ) + where + +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.Trans +import GHC.Conc (unsafeIOToSTM) +import Data.Dynamic +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Response +import System.IO.Unsafe +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.DOM.XmlKeywords + + +data Abortion = Abortion { + aboStatus :: StatusCode + , aboHeaders :: Headers + , aboMessage :: String + } deriving (Show, Typeable) + + +abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a +abort status headers msg + = liftIO $ abortIO status headers msg + + +abortIO :: StatusCode -> [ (String, String) ] -> String -> IO a +abortIO status headers msg + = let abo = Abortion status headers msg + exc = DynException (toDyn abo) + in + throwIO exc + + +abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a +abortSTM status headers msg + = unsafeIOToSTM $ abortIO status headers msg + + +abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c +abortA status headers msg + = arrIO0 $ abortIO status headers msg + + +aboPage :: Config -> Abortion -> String +aboPage conf abo + = let [html] = unsafePerformIO + $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo) + >>> + writeDocumentToString [(a_indent, v_1)] + ) + in + html diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 2d37022..4932a14 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -5,16 +5,22 @@ module Network.HTTP.Lucu.Config where import Network +import Network.BSD +import System.IO.Unsafe data Config = Config { - cnfServerPort :: PortID + cnfServerSoftware :: String + , cnfServerHost :: HostName + , cnfServerPort :: PortID , cnfMaxPipelineDepth :: Int - , cnfMaxEntityLength :: Integer + , cnfMaxEntityLength :: Int , cnfMaxURILength :: Int } defaultConfig = Config { - cnfServerPort = Service "http" + cnfServerSoftware = "Lucu/1.0" + , cnfServerHost = unsafePerformIO getHostName + , cnfServerPort = Service "http" , cnfMaxPipelineDepth = 100 , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB , cnfMaxURILength = 4 * 1024 -- 4 KiB diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 8c30315..f5cc476 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,6 +1,7 @@ module Network.HTTP.Lucu.DefaultPage - ( getDefaultPage -- Maybe Request -> Response -> String + ( getDefaultPage -- Config -> Maybe Request -> Response -> String , writeDefaultPage -- Interaction -> STM () + , mkDefaultPage -- (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree ) where @@ -11,10 +12,13 @@ import Control.Monad import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe +import Network +import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import Network.URI import System.IO.Unsafe import Text.Printf import Text.XML.HXT.Arrow.WriteDocument @@ -24,12 +28,12 @@ import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords -getDefaultPage :: Maybe Request -> Response -> String -getDefaultPage req res +getDefaultPage :: Config -> Maybe Request -> Response -> String +getDefaultPage conf req res = let msgA = getMsg req res in unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA + do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA >>> writeDocumentToString [ (a_indent, v_1) ] ) @@ -52,7 +56,8 @@ writeDefaultPage itr let reqM = itrRequest itr res = fromJust resM - page = B.pack $ getDefaultPage reqM res + conf = itrConfig itr + page = B.pack $ getDefaultPage conf reqM res writeTVar (itrResponse itr) $ Just $ setHeader "Content-Type" "application/xhtml+xml" res @@ -61,9 +66,17 @@ writeDefaultPage itr $ page -mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree -mkDefaultPage status msgA +mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree +mkDefaultPage conf status msgA = let (sCode, sMsg) = statusCode status + sig = cnfServerSoftware conf + ++ " at " + ++ cnfServerHost conf + ++ ( case cnfServerPort conf of + Service serv -> ", service " ++ serv + PortNumber num -> ", port " ++ show num + UnixSocket path -> ", unix socket " ++ show path + ) in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" @@ -75,14 +88,87 @@ mkDefaultPage status msgA += ( eelem "h1" += txt sMsg ) - += ( msgA - >>> - eelem "p" += ( this - >>> - mkText - ))))) + += ( eelem "p" += msgA ) + += eelem "hr" + += ( eelem "address" += txt sig )))) -getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String +getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree getMsg req res - = constA "FIXME: NOT IMPL" + = case resStatus res of + -- 1xx は body を持たない + -- 2xx の body は補完しない + + -- 3xx + MovedPermanently + -> txt (printf "The resource at %s has been moved to " path) + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt " permanently." + + Found + -> txt (printf "The resource at %s is currently located at " path) + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt ". This is not a permanent relocation." + + SeeOther + -> txt (printf "The resource at %s can be found at " path) + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt "." + + TemporaryRedirect + -> txt (printf "The resource at %s is temporarily located at " path) + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt "." + + -- 4xx + BadRequest + -> txt "The server could not understand the request you sent." + + Unauthorized + -> txt (printf "You need a valid authentication to access %s" path) + + Forbidden + -> txt (printf "You don't have permission to access %s" path) + + NotFound + -> txt (printf "The requested URL %s was not found on this server." path) + + Gone + -> txt (printf "The resource at %s was here in past times, but has gone permanently." path) + + RequestEntityTooLarge + -> txt (printf "The request entity you sent for %s was too big to accept." path) + + RequestURITooLarge + -> txt "The request URI you sent was too big to accept." + + -- 5xx + InternalServerError + -> txt (printf "An internal server error has occured during the process of your request to %s" path) + + ServiceUnavailable + -> txt "The service is temporarily unavailable. Try later." + + _ -> none + + + where + path :: String + path = let uri = reqURI $ fromJust req + in + uriPath uri + + loc :: String + loc = fromJust $ getHeader "Location" res diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 6b872ca..491c029 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -3,7 +3,7 @@ module Network.HTTP.Lucu.Interaction , InteractionState(..) , InteractionQueue , newInteractionQueue -- IO InteractionQueue - , newInteraction -- HostName -> Maybe Request -> IO Interaction + , newInteraction -- Config -> HostName -> Maybe Request -> IO Interaction , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM () , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b @@ -19,25 +19,34 @@ import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.Sequence as S import Data.Sequence (Seq) import Network +import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response data Interaction = Interaction { - itrRemoteHost :: HostName + itrConfig :: Config + , itrRemoteHost :: HostName , itrRequest :: Maybe Request , itrResponse :: TVar (Maybe Response) , itrRequestHasBody :: TVar Bool - , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明 , itrRequestIsChunked :: TVar Bool - , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される - , itrExpectedContinue :: TVar Bool - , itrWillChunkBody :: TVar Bool - , itrWillDiscardBody :: TVar Bool - , itrWillClose :: TVar Bool - , itrBodyToSend :: TVar ByteString + , itrReqChunkLength :: TVar (Maybe Int) + , itrReqChunkRemaining :: TVar (Maybe Int) + , itrReqChunkIsOver :: TVar Bool + , itrReqBodyWanted :: TVar (Maybe Int) + , itrReqBodyWasteAll :: TVar Bool + , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される + + , itrWillReceiveBody :: TVar Bool + , itrWillChunkBody :: TVar Bool + , itrWillDiscardBody :: TVar Bool + , itrWillClose :: TVar Bool + + , itrBodyToSend :: TVar ByteString + , itrBodyIsNull :: TVar Bool , itrState :: TVar InteractionState @@ -53,7 +62,7 @@ data InteractionState = ExaminingHeader | DecidingHeader | DecidingBody | Done - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Enum) type InteractionQueue = TVar (Seq Interaction) @@ -62,21 +71,28 @@ newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty -newInteraction :: HostName -> Maybe Request -> IO Interaction -newInteraction host req +newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction +newInteraction conf host req = do responce <- newTVarIO Nothing - requestHasBody <- newTVarIO False - requestBodyLength <- newTVarIO Nothing - requestIsChunked <- newTVarIO False - receivedBody <- newTVarIO B.empty - - expectedContinue <- newTVarIO False - - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - bodyToSend <- newTVarIO B.empty + requestHasBody <- newTVarIO False + requestIsChunked <- newTVarIO False + expectedContinue <- newTVarIO False + + reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長 + reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り + reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた + reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長 + reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 + receivedBody <- newTVarIO B.empty + + willReceiveBody <- newTVarIO False + willChunkBody <- newTVarIO False + willDiscardBody <- newTVarIO False + willClose <- newTVarIO False + + bodyToSend <- newTVarIO B.empty + bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False state <- newTVarIO undefined @@ -84,21 +100,29 @@ newInteraction host req wroteHeader <- newTVarIO False return $ Interaction { - itrRemoteHost = host + itrConfig = conf + , itrRemoteHost = host , itrRequest = req , itrResponse = responce , itrRequestHasBody = requestHasBody - , itrRequestBodyLength = requestBodyLength , itrRequestIsChunked = requestIsChunked + , itrExpectedContinue = expectedContinue + + , itrReqChunkLength = reqChunkLength + , itrReqChunkRemaining = reqChunkRemaining + , itrReqChunkIsOver = reqChunkIsOver + , itrReqBodyWanted = reqBodyWanted + , itrReqBodyWasteAll = reqBodyWasteAll , itrReceivedBody = receivedBody - , itrExpectedContinue = expectedContinue + , itrWillReceiveBody = willReceiveBody + , itrWillChunkBody = willChunkBody + , itrWillDiscardBody = willDiscardBody + , itrWillClose = willClose - , itrWillChunkBody = willChunkBody - , itrWillDiscardBody = willDiscardBody - , itrWillClose = willClose - , itrBodyToSend = bodyToSend + , itrBodyToSend = bodyToSend + , itrBodyIsNull = bodyIsNull , itrState = state diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 929413c..7d7e147 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,6 +1,6 @@ module Network.HTTP.Lucu.Postprocess ( postprocess -- Interaction -> STM () - , completeUnconditionalHeaders -- Response -> IO Response + , completeUnconditionalHeaders -- Config -> Response -> IO Response ) where @@ -9,6 +9,8 @@ import Control.Monad import Data.Char import Data.Maybe import GHC.Conc (unsafeIOToSTM) +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction @@ -20,7 +22,14 @@ import System.Time {- - * Response が未設定なら、HTTP/1.1 500 Internal Server Error にする。 + * Response が未設定なら、200 OK にする。 + + * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。 + + * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。 + + * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に + する。 * Content-Length があれば、それを削除する。 @@ -33,7 +42,7 @@ import System.Time * body を持つ事が出來る時、Content-Type が無ければ application/octet-stream にする。出來ない時、HEAD でなければ - Content-Type を削除する。 + Content-Type, Etag, Last-Modified を削除する。 * body を持つ事が出來ない時、body 破棄フラグを立てる。 @@ -47,22 +56,41 @@ import System.Time -} -{- Postprocess は body を補完した後で實行する事 -} - postprocess :: Interaction -> STM () postprocess itr - = do res <- readItr itr itrResponse id - - when (res == Nothing) - $ setStatus itr InternalServerError + = 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 [] + ("The status code is not good for a final status: " + ++ show sc) + + when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) + $ abortSTM InternalServerError [] + ("The status was " ++ show sc ++ " but no Allow header.") + + when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) + $ abortSTM InternalServerError [] + ("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 $ fromJust oldRes + newRes <- unsafeIOToSTM + $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes) writeItr itr itrResponse $ Just newRes where + relyOnRequest :: Interaction -> STM () relyOnRequest itr = do status <- readItr itr itrResponse (resStatus . fromJust) @@ -88,14 +116,20 @@ postprocess itr | x <- splitBy (== ',') (map toLower te)] in when (teList == [] || last teList /= "chunked") - $ setStatus itr InternalServerError + $ abortSTM InternalServerError [] + ("Transfer-Encoding must end with `chunked' " + ++ "because this is an HTTP/1.1 request: " + ++ te) writeItr itr itrWillChunkBody True else case fmap (map toLower) teM of Nothing -> return () Just "identity" -> return () - _ -> setStatus itr InternalServerError + Just te -> abortSTM InternalServerError [] + ("Transfer-Encoding must be `identity' because " + ++ "this is an HTTP/1.0 request: " + ++ te) cType <- readHeader itr "Content-Type" when (cType == Nothing) @@ -104,24 +138,22 @@ postprocess itr -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す do updateRes itr $ deleteHeader "Transfer-Encoding" when (reqMethod req /= HEAD) - $ updateRes itr $ deleteHeader "Content-Type" + $ do updateRes itr $ deleteHeader "Content-Type" + updateRes itr $ deleteHeader "Etag" + updateRes itr $ deleteHeader "Last-Modified" conn <- readHeader itr "Connection" case fmap (map toLower) conn of Just "close" -> writeItr itr itrWillClose True - _ -> updateRes itr $ setHeader "Connection" "close" + _ -> return () + + willClose <- readItr itr itrWillClose id + when willClose + $ updateRes itr $ setHeader "Connection" "close" when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True - setStatus :: Interaction -> StatusCode -> STM () - setStatus itr status - = writeTVar (itrResponse itr) (Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - }) - readHeader :: Interaction -> String -> STM (Maybe String) readHeader itr name = do valueMM <- readItrF itr itrResponse $ getHeader name @@ -134,13 +166,13 @@ postprocess itr = updateItrF itr itrResponse updator -completeUnconditionalHeaders :: Response -> IO Response -completeUnconditionalHeaders res +completeUnconditionalHeaders :: Config -> Response -> IO Response +completeUnconditionalHeaders conf res = return res >>= compServer >>= compDate >>= return where compServer res = case getHeader "Server" res of - Nothing -> return $ addHeader "Server" "Lucu/1.0" res + Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res Just _ -> return res compDate res diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 3552e48..d951f6a 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -110,7 +110,9 @@ preprocess itr "content-length" -> if all isDigit value then - writeItr itr itrRequestBodyLength $ Just $ read value + do let len = read value + writeItr itr itrReqChunkLength $ Just len + writeItr itr itrReqChunkRemaining $ Just len else setStatus itr BadRequest diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 567b98b..b0c22be 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -55,20 +55,19 @@ requestReader cnf tree h host tQueue let input = B.append soFar chunk case parse requestP input of (Success req , input') -> acceptParsableRequest req input' - (IllegalInput, _ ) -> acceptNonparsableRequest + (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest (ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then -- ヘッダ長過ぎ - acceptNonparsableRequest + acceptNonparsableRequest RequestEntityTooLarge else acceptRequest input - - acceptNonparsableRequest :: IO () - acceptNonparsableRequest - = do itr <- newInteraction host Nothing + acceptNonparsableRequest :: StatusCode -> IO () + acceptNonparsableRequest status + = do itr <- newInteraction cnf host Nothing let res = Response { resVersion = HttpVersion 1 1 - , resStatus = BadRequest + , resStatus = status , resHeaders = [] } atomically $ do writeItr itr itrResponse $ Just res @@ -80,7 +79,7 @@ requestReader cnf tree h host tQueue acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req soFar - = do itr <- newInteraction host (Just req) + = do itr <- newInteraction cnf host (Just req) action <- atomically $ do preprocess itr @@ -132,7 +131,86 @@ requestReader cnf tree h host tQueue acceptRequest soFar observeRequest :: Interaction -> ByteString -> IO () - observeRequest itr soFar = fail "FIXME: Not Implemented" + observeRequest itr soFar + = do isChunked <- atomically $ readItr itr itrRequestIsChunked id + if isChunked then + observeChunkedRequest itr soFar + else + observeNonChunkedRequest itr soFar + + observeChunkedRequest :: Interaction -> ByteString -> IO () + observeChunkedRequest itr soFar + = fail "FIXME: not implemented" + + observeNonChunkedRequest :: Interaction -> ByteString -> IO () + observeNonChunkedRequest itr soFar + = fail "FIXME: not implemented" +{- + = do action + <- atomically $ + do wantedM <- readItr itr itrReqBodyWanted id + if wantedM == Nothing then + do wasteAll <- readItr itr itrReqBodyWasteAll id + if wasteAll then + return $ wasteAllReqBody itr soFar + else + retry + else + -- 受信要求が來た。 + if B.empty soFar then + return $ receiveNonChunkedReqBody itr + else + do remaining <- readItr itr itrReqChunkRemaining fromJust + + let wanted = fromJust wanted + (chunk, input') = B.splitAt (min wanted remaining) soFar + newRemaining = remaining - B.length chunk + isOver = newRemaining == 0 + + writeItr itr itrReqChunkRemaining newRemaining + writeItr itr itrReqChunkIsOver isOver + writeItr itr itrReqBodyWanted (if isOver then + Nothing + else + Just wanted) + writeItr itr itrReceivedBody chunk + + if isOver then + return $ acceptRequest input' + else + return $ observeNonChunkedRequest itr input' + action + + receiveNonChunkedReqBody :: Interaction -> IO () + receiveNonChunkedReqBody itr + = do wanted <- atomically $ readItr itr itrReqBodyWanted fromJust + remaining <- atomically $ readItr itr itrReqChunkRemaining fromJust + + hWaitForInput h (-1) + chunk <- B.hGetNonBlocking h (min wanted remaining) + + let newRemaining = remaining - B.length chunk + isOver = newRemaining == 0 + + atomically $ do writeItr itr itrReqChunkRemaining newRemaining + writeItr itr itrReqChunkIsOver isOver + writeItr itr itrReqBodyWanted (if isOver then + Nothing + else + Just wanted) + writeItr itr itrReceivedBody chunk + + if isOver then + return $ acceptRequest B.empty + else + return $ observeNonChunkedRequest itr B.empty + + + wasteAllReqBody :: Interaction -> ByteString -> IO () + wasteAllReqBody itr soFar + = + +-} enqueue :: Interaction -> STM () enqueue itr = do queue <- readTVar tQueue diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 2e4d46e..7405975 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -5,19 +5,50 @@ module Network.HTTP.Lucu.Resource , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ResourceDef , runResource -- ResourceDef -> Interaction -> IO ThreadId + + , input -- Int -> Resource String + , inputChunk -- Int -> Resource String + , inputBS -- Int -> Resource ByteString + , inputChunkBS -- Int -> Resource ByteString + + , setStatus -- StatusCode -> Resource () + , setHeader -- String -> String -> Resource () + + , redirect -- StatusCode -> URI -> Resource () + + , output -- String -> Resource () + , outputChunk -- String -> Resource () + , outputBS -- ByteString -> Resource () + , outputChunkBS -- ByteString -> Resource () ) where import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Dynamic import Data.List import qualified Data.Map as M import Data.Map (Map) +import Data.Maybe +import GHC.Conc (unsafeIOToSTM) +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import qualified Network.HTTP.Lucu.Headers as H +import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils import Network.URI +import Prelude hiding (catch) +import System.IO +import System.IO.Error hiding (catch) type Resource a = ReaderT Interaction IO a @@ -30,7 +61,11 @@ type Resource a = ReaderT Interaction IO a data ResourceDef = ResourceDef { resUsesNativeThread :: Bool , resIsGreedy :: Bool - , resResource :: Resource () + , resGet :: Maybe (Resource ()) + , resHead :: Maybe (Resource ()) + , resPost :: Maybe (Resource ()) + , resPut :: Maybe (Resource ()) + , resDelete :: Maybe (Resource ()) } type ResTree = ResNode -- root だから Map ではない type ResSubtree = Map String ResNode @@ -101,9 +136,306 @@ findResource (ResNode rootDefM subtree) uri runResource :: ResourceDef -> Interaction -> IO ThreadId -runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch +runResource def itr + = fork + $ catch ( runReaderT ( do fromMaybe notAllowed rsrc + driftTo Done + ) itr + ) + $ \ exc -> processException (itrConfig itr) exc where + fork :: IO () -> IO ThreadId fork = if (resUsesNativeThread def) then forkOS else forkIO - rsrc = resResource def \ No newline at end of file + + 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 + where + tooLarge :: Int -> STM () + tooLarge lim = abortSTM RequestEntityTooLarge [] + ("Request body must be smaller than " + ++ show lim ++ " bytes.") + + +inputChunk :: Int -> Resource String +inputChunk limit = inputChunkBS limit >>= return . B.unpack + + +-- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit +-- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され +-- る。これ以上ボディが殘ってゐなければ空文字列を返す。 +inputChunkBS :: Int -> Resource ByteString +inputChunkBS limit + = do driftTo GettingBody + itr <- ask + let defaultLimit = cnfMaxEntityLength $ itrConfig itr + actualLimit = if limit < 0 then + defaultLimit + else + limit + when (actualLimit <= 0) + $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) + -- Reader にリクエスト + liftIO $ atomically + $ do writeItr itr itrReqBodyWanted $ Just actualLimit + writeItr itr itrWillReceiveBody True + -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 + chunk <- liftIO $ atomically + $ do chunk <- readItr itr itrReceivedBody id + -- 要求された量に滿たなくて、まだ殘りがあるなら + -- 再試行。 + when (B.length chunk < fromIntegral actualLimit) + $ do chunkIsOver <- readItr itr itrReqChunkIsOver id + unless chunkIsOver + $ retry + -- 成功 + writeItr itr itrReceivedBody B.empty + return chunk + when (B.null chunk) + $ driftTo DecidingHeader + return chunk + + +setStatus :: StatusCode -> Resource () +setStatus code + = 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 + } + + +setHeader :: String -> String -> Resource () +setHeader name value + = do driftTo DecidingHeader + 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 + + +redirect :: StatusCode -> URI -> Resource () +redirect code uri + = do when (code == NotModified || not (isRedirection code)) + $ abort InternalServerError [] + $ "Attempted to redirect with status " ++ show code + setStatus code + setHeader "Location" (uriToString id uri $ "") + + +output :: String -> Resource () +output = outputBS . B.pack + + +outputBS :: ByteString -> Resource () +outputBS str = do outputChunkBS str + driftTo Done + + +outputChunk :: String -> Resource () +outputChunk = outputChunkBS . B.pack + + +outputChunkBS :: ByteString -> Resource () +outputChunkBS str = do driftTo DecidingBody + itr <- ask + liftIO $ atomically $ + do updateItr itr itrBodyToSend (flip B.append str) + unless (B.null str) + $ writeItr itr itrBodyIsNull False + + +{- + + [GettingBody からそれ以降の状態に遷移する時] + + body を讀み終へてゐなければ、殘りの body を讀み捨てる。 + + + [DecidingHeader からそれ以降の状態に遷移する時] + + postprocess する。 + + + [Done に遷移する時] + + bodyIsNull が False ならば何もしない。True だった場合は出力補完す + る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK + だった場合は、補完の代はりに 204 No Content に變へる。 + +-} + +driftTo :: InteractionState -> Resource () +driftTo newState + = do itr <- ask + liftIO $ atomically $ do oldState <- readItr itr itrState id + if newState < oldState then + throwStateError oldState newState + else + do let a = [oldState .. newState] + b = tail a + c = zip a b + mapM_ (uncurry $ drift itr) c + writeItr itr itrState newState + where + throwStateError :: Monad m => InteractionState -> InteractionState -> m a + + throwStateError Done DecidingBody + = fail "It makes no sense to output something after finishing to output." + + throwStateError old new + = fail ("state error: " ++ show old ++ " ==> " ++ show new) + + + drift :: Interaction -> InteractionState -> InteractionState -> STM () + + drift itr GettingBody _ + = writeItr itr itrReqBodyWasteAll True + + drift itr DecidingHeader _ + = postprocess itr + + 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 + + + drift _ _ _ + = return () + + + readStatus :: Interaction -> STM StatusCode + readStatus itr = readItr itr itrResponse (resStatus . fromJust) \ No newline at end of file diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 1c19da4..54d57b2 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -3,11 +3,14 @@ module Network.HTTP.Lucu.Response , Response(..) , hPutResponse -- Handle -> Response -> IO () , isInformational -- StatusCode -> Bool + , isSuccessful -- StatusCode -> Bool + , isRedirection -- StatusCode -> Bool , isError -- StatusCode -> Bool , statusCode -- StatusCode -> (Int, String) ) where +import Data.Dynamic import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import System.IO @@ -63,7 +66,7 @@ data StatusCode = Continue | GatewayTimeout | HttpVersionNotSupported | InsufficientStorage - deriving (Eq) + deriving (Typeable, Eq) instance Show StatusCode where show sc = let (num, msg) = statusCode sc @@ -97,12 +100,21 @@ hPutStatus h sc = let (num, msg) = statusCode sc isInformational :: StatusCode -> Bool -isInformational sc = let (num, _) = statusCode sc - in num < 200 +isInformational = doesMeet (< 200) + +isSuccessful :: StatusCode -> Bool +isSuccessful = doesMeet (\ n -> n >= 200 && n < 300) + +isRedirection :: StatusCode -> Bool +isRedirection = doesMeet (\ n -> n >= 300 && n < 400) isError :: StatusCode -> Bool -isError sc = let (num, _) = statusCode sc - in num >= 400 +isError = doesMeet (>= 400) + +doesMeet :: (Int -> Bool) -> StatusCode -> Bool +doesMeet p sc = let (num, _) = statusCode sc + in + p num statusCode :: StatusCode -> (Int, String) diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index ebd97e7..373930a 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -124,7 +124,7 @@ responseWriter h tQueue readerTID = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id willChunkBody <- atomically $ readItr itr itrWillChunkBody id when (not willDiscardBody && willChunkBody) - $ hPutStr h "0\r\n" >> hFlush h + $ hPutStr h "0\r\n\r\n" >> hFlush h finalize :: Interaction -> IO () finalize itr @@ -136,6 +136,8 @@ responseWriter h tQueue readerTID readItr itr itrWillClose id if willClose then + -- reader は恐らく hWaitForInput してゐる最中なので、 + -- スレッドを豫め殺して置かないとをかしくなる。 do killThread readerTID hClose h else diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 7d6eeeb..df19a76 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,13 +1,17 @@ module Network.HTTP.Lucu.Utils ( splitBy -- (a -> Bool) -> [a] -> [[a]] + , joinWith -- [a] -> [[a]] -> [a] , trim -- (a -> Bool) -> [a] -> [a] , noCaseEq -- String -> String -> Bool , isWhiteSpace -- Char -> Bool ) where +import Control.Monad.Trans import Data.Char import Data.List +import Foreign +import Foreign.C splitBy :: (a -> Bool) -> [a] -> [[a]] @@ -17,6 +21,11 @@ splitBy isSeparator src (first, sep:rest) -> first : splitBy isSeparator rest +joinWith :: [a] -> [[a]] -> [a] +joinWith separator xs + = foldr (++) [] $ intersperse separator xs + + trim :: (a -> Bool) -> [a] -> [a] trim p = trimTail . trimHead where diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index fe5b543..69d7a05 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,12 +1,31 @@ +import Data.Maybe import Network import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Httpd import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Response +import Network.URI import System.Posix.Signals main :: IO () main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } - resources = mkResTree [] + resources = mkResTree [ ([], helloWorld) ] in do installHandler sigPIPE Ignore Nothing - runHttpd config resources \ No newline at end of file + runHttpd config resources + + +helloWorld :: ResourceDef +helloWorld + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet + = Just $ do setHeader "Content-Type" "text/plain" + outputChunk "Hello, " + outputChunk "World!\n" + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } \ No newline at end of file -- 2.40.0