From 50e8fe7af585a8d33d93b3721be8f8f01905b891 Mon Sep 17 00:00:00 2001 From: pho Date: Sun, 7 Oct 2007 08:50:17 +0900 Subject: [PATCH] Implemented fallback handler. darcs-hash:20071006235017-62b54-91495fb6db24232c08e4cd7b08e44d1451b00d2b.gz --- Network/HTTP/Lucu/Abortion.hs | 2 +- Network/HTTP/Lucu/DefaultPage.hs | 4 +- Network/HTTP/Lucu/Headers.hs | 10 +-- Network/HTTP/Lucu/HttpVersion.hs | 3 +- Network/HTTP/Lucu/Httpd.hs | 22 +++-- Network/HTTP/Lucu/RequestReader.hs | 18 +++-- Network/HTTP/Lucu/Resource/Tree.hs | 55 +++++++++---- Network/HTTP/Lucu/Response.hs | 121 +++++++++++++++------------- Network/HTTP/Lucu/ResponseWriter.hs | 18 ++--- examples/HelloWorld.hs | 6 +- examples/Implanted.hs | 2 +- examples/ImplantedSmall.hs | 2 +- examples/Multipart.hs | 2 +- 13 files changed, 149 insertions(+), 116 deletions(-) diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 091b1bb..bc03045 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -70,7 +70,7 @@ abort status headers msg in liftIO $ throwIO exc --- |This is similar to 'abort' but compute it with +-- |This is similar to 'abort' but computes it with -- 'System.IO.Unsafe.unsafePerformIO'. abortPurely :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> a abortPurely = ((unsafePerformIO .) .) . abort diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index f53501f..be369cc 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -75,11 +75,11 @@ mkDefaultPage conf status msgA += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (fmtDec 3 sCode ++ " " ++ sMsg) + += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg) )) += ( eelem "body" += ( eelem "h1" - += txt sMsg + += txt (C8.unpack sMsg) ) += ( eelem "p" += msgA ) += eelem "hr" diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 28723bc..4ad6043 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -207,12 +207,12 @@ headersP = do xs <- many header hPutHeaders :: Handle -> Headers -> IO () hPutHeaders h hds = h `seq` hds `seq` - mapM_ putH (M.toList hds) >> hPutStr h "\r\n" + mapM_ putH (M.toList hds) >> C8.hPut h (C8.pack "\r\n") where putH :: (NCBS, ByteString) -> IO () putH (name, value) = name `seq` value `seq` - do C8.hPutStr h (fromNCBS name) - C8.hPutStr h (C8.pack ": ") - C8.hPutStr h value - C8.hPutStr h (C8.pack "\r\n") + do C8.hPut h (fromNCBS name) + C8.hPut h (C8.pack ": ") + C8.hPut h value + C8.hPut h (C8.pack "\r\n") diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index bd904e8..9bc1b81 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -8,6 +8,7 @@ module Network.HTTP.Lucu.HttpVersion ) where +import qualified Data.ByteString.Char8 as C8 import Network.HTTP.Lucu.Parser import System.IO @@ -42,7 +43,7 @@ httpVersionP = do string "HTTP/" hPutHttpVersion :: Handle -> HttpVersion -> IO () hPutHttpVersion h (HttpVersion maj min) = h `seq` - do hPutStr h "HTTP/" + do C8.hPut h (C8.pack "HTTP/") hPutStr h (show maj) hPutChar h '.' hPutStr h (show min) \ No newline at end of file diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index cbbb517..2036412 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,6 +1,7 @@ --- | The entry point of Lucu httpd. +-- |The entry point of Lucu httpd. module Network.HTTP.Lucu.Httpd - ( runHttpd + ( FallbackHandler + , runHttpd ) where @@ -34,7 +35,7 @@ import System.Posix.Signals -- > main = let config = defaultConfig -- > resources = mkResTree [ ([], helloWorld) ] -- > in --- > runHttpd config resourcees +-- > runHttpd config resourcees [] -- > -- > helloWorld :: ResourceDef -- > helloWorld = ResourceDef { @@ -48,10 +49,9 @@ import System.Posix.Signals -- > , resPut = Nothing -- > , resDelete = Nothing -- > } -runHttpd :: Config -> ResTree -> IO () -runHttpd cnf tree - = cnf `seq` tree `seq` - withSocketsDo $ +runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO () +runHttpd cnf tree fbs + = withSocketsDo $ do installHandler sigPIPE Ignore Nothing so <- listenOn (cnfServerPort cnf) loop so @@ -60,16 +60,14 @@ runHttpd cnf tree loop so -- 本當は Network.accept を使ひたいが、このアクションは勝手に -- リモートのIPを逆引きするので、使へない。 - = so `seq` - do (h, addr) <- accept' so + = do (h, addr) <- accept' so tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree h addr tQueue + readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue writerTID <- forkIO $ responseWriter cnf h tQueue readerTID loop so accept' :: Socket -> IO (Handle, So.SockAddr) accept' soSelf - = soSelf `seq` - do (soPeer, addr) <- So.accept soSelf + = do (soPeer, addr) <- So.accept soSelf hPeer <- So.socketToHandle soPeer ReadWriteMode return (hPeer, addr) diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 8760cb8..c6cdc0e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -11,6 +11,7 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe import qualified Data.Sequence as S import Data.Sequence ((<|)) +import GHC.Conc (unsafeIOToSTM) import Network.Socket import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk @@ -26,9 +27,9 @@ import Prelude hiding (catch) import System.IO -requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO () -requestReader cnf tree h addr tQueue - = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq` +requestReader :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO () +requestReader cnf tree fbs h addr tQueue + = cnf `seq` tree `seq` fbs `seq` h `seq` addr `seq` tQueue `seq` do catch (do input <- B.hGetContents h acceptRequest input) $ \ exc -> case exc of @@ -79,12 +80,13 @@ requestReader cnf tree h addr tQueue if isErr then acceptSemanticallyInvalidRequest itr input else - case findResource tree $ reqURI req of - Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr input + do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req + case rsrcM of + Nothing -- Resource が無かった + -> acceptRequestForNonexistentResource itr input - Just (rsrcPath, rsrcDef) -- あった - -> acceptRequestForExistentResource itr input rsrcPath rsrcDef + Just (rsrcPath, rsrcDef) -- あった + -> acceptRequestForExistentResource itr input rsrcPath rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index bb12dd0..2cd498f 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,6 +4,8 @@ module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) , ResTree + , FallbackHandler + , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) @@ -35,6 +37,15 @@ import System.IO.Error hiding (catch) import Prelude hiding (catch) +-- |'FallbackHandler' is an extra resource handler for resources which +-- can't be statically located somewhere in the resource tree. The +-- Lucu httpd first search for a resource in the tree, and then call +-- fallback handlers to ask them for a resource. If all of the +-- handlers returned 'Prelude.Nothing', the httpd responds with 404 +-- Not Found. +type FallbackHandler = [String] -> IO (Maybe ResourceDef) + + -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは @@ -55,7 +66,7 @@ data ResourceDef = ResourceDef { -- greedy resource at \/aaa\/bbb, it is always chosen even if -- there is another resource at \/aaa\/bbb\/ccc. If the resource -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy - -- resource is like a CGI script. + -- resources are like CGI scripts. , resIsGreedy :: !Bool -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET -- request comes for the resource path. If 'resGet' is Nothing, @@ -89,13 +100,13 @@ data ResourceDef = ResourceDef { , resDelete :: !(Maybe (Resource ())) } --- | 'ResTree' is an opaque structure which is a map from resource --- path to 'ResourceDef'. -type ResTree = ResNode -- root だから Map ではない +-- |'ResTree' is an opaque structure which is a map from resource path +-- to 'ResourceDef'. +newtype ResTree = ResTree ResNode -- root だから Map ではない type ResSubtree = Map String ResNode data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree --- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. +-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- -- @ -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ @@ -112,12 +123,12 @@ mkResTree list = list `seq` processRoot list in if null roots then -- "/" にリソースが定義されない。"/foo" とかにはあるかも。 - ResNode Nothing children + ResTree (ResNode Nothing children) else -- "/" がある。 let (_, def) = last roots in - ResNode (Just def) children + ResTree (ResNode (Just def) children) processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree processNonRoot list @@ -139,16 +150,19 @@ mkResTree list = list `seq` processRoot list subtree -findResource :: ResTree -> URI -> Maybe ([String], ResourceDef) -findResource (ResNode rootDefM subtree) uri - = let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - in - if null path then - do def <- rootDefM - return (path, def) - else - walkTree subtree path [] +findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef)) +findResource (ResTree (ResNode rootDefM subtree)) fbs uri + = do let pathStr = uriPath uri + path = [x | x <- splitBy (== '/') pathStr, x /= ""] + foundInTree = if null path then + do def <- rootDefM + return (path, def) + else + walkTree subtree path [] + if isJust foundInTree then + return foundInTree + else + fallback path fbs where walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) @@ -167,6 +181,13 @@ findResource (ResNode rootDefM subtree) uri return (soFar ++ [x], def) _ -> walkTree children xs (soFar ++ [x]) + fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef)) + fallback _ [] = return Nothing + fallback path (x:xs) = do m <- x path + case m of + Just def -> return $! Just ([], def) + Nothing -> fallback path xs + runResource :: ResourceDef -> Interaction -> IO ThreadId runResource def itr diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index b1ad3d8..fd949fe 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -15,6 +15,8 @@ module Network.HTTP.Lucu.Response ) where +import Data.ByteString.Base (ByteString) +import qualified Data.ByteString.Char8 as C8 import Data.Dynamic import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Headers @@ -78,9 +80,9 @@ data StatusCode = Continue deriving (Typeable, Eq) instance Show StatusCode where - show sc = let (# num, msg #) = statusCode sc - in - (fmtDec 3 num) ++ " " ++ msg + show sc = case statusCode sc of + (# num, msg #) + -> (fmtDec 3 num) ++ " " ++ C8.unpack msg data Response = Response { @@ -101,13 +103,18 @@ hPutResponse h res do hPutHttpVersion h (resVersion res) hPutChar h ' ' hPutStatus h (resStatus res) - hPutStr h "\r\n" + C8.hPut h (C8.pack "\r\n") hPutHeaders h (resHeaders res) hPutStatus :: Handle -> StatusCode -> IO () hPutStatus h sc = h `seq` sc `seq` - hPutStr h (show sc) + case statusCode sc of + (# num, msg #) + -> do hPutStr h (fmtDec 3 num) + hPutChar h ' ' + C8.hPut h msg + -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. isInformational :: StatusCode -> Bool @@ -141,55 +148,55 @@ doesMeet p sc = case statusCode sc of -- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual -- representation of @sc@. -statusCode :: StatusCode -> (# Int, String #) - -statusCode Continue = (# 100, "Continue" #) -statusCode SwitchingProtocols = (# 101, "Switching Protocols" #) -statusCode Processing = (# 102, "Processing" #) - -statusCode Ok = (# 200, "OK" #) -statusCode Created = (# 201, "Created" #) -statusCode Accepted = (# 202, "Accepted" #) -statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #) -statusCode NoContent = (# 204, "No Content" #) -statusCode ResetContent = (# 205, "Reset Content" #) -statusCode PartialContent = (# 206, "Partial Content" #) -statusCode MultiStatus = (# 207, "Multi Status" #) - -statusCode MultipleChoices = (# 300, "Multiple Choices" #) -statusCode MovedPermanently = (# 301, "Moved Permanently" #) -statusCode Found = (# 302, "Found" #) -statusCode SeeOther = (# 303, "See Other" #) -statusCode NotModified = (# 304, "Not Modified" #) -statusCode UseProxy = (# 305, "Use Proxy" #) -statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #) - -statusCode BadRequest = (# 400, "Bad Request" #) -statusCode Unauthorized = (# 401, "Unauthorized" #) -statusCode PaymentRequired = (# 402, "Payment Required" #) -statusCode Forbidden = (# 403, "Forbidden" #) -statusCode NotFound = (# 404, "Not Found" #) -statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #) -statusCode NotAcceptable = (# 406, "Not Acceptable" #) -statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #) -statusCode RequestTimeout = (# 408, "Request Timeout" #) -statusCode Conflict = (# 409, "Conflict" #) -statusCode Gone = (# 410, "Gone" #) -statusCode LengthRequired = (# 411, "Length Required" #) -statusCode PreconditionFailed = (# 412, "Precondition Failed" #) -statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #) -statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #) -statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #) -statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #) -statusCode ExpectationFailed = (# 417, "Expectation Failed" #) -statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #) -statusCode Locked = (# 423, "Locked" #) -statusCode FailedDependency = (# 424, "Failed Dependency" #) - -statusCode InternalServerError = (# 500, "Internal Server Error" #) -statusCode NotImplemented = (# 501, "Not Implemented" #) -statusCode BadGateway = (# 502, "Bad Gateway" #) -statusCode ServiceUnavailable = (# 503, "Service Unavailable" #) -statusCode GatewayTimeout = (# 504, "Gateway Timeout" #) -statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #) -statusCode InsufficientStorage = (# 507, "Insufficient Storage" #) \ No newline at end of file +statusCode :: StatusCode -> (# Int, ByteString #) + +statusCode Continue = (# 100, C8.pack "Continue" #) +statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #) +statusCode Processing = (# 102, C8.pack "Processing" #) + +statusCode Ok = (# 200, C8.pack "OK" #) +statusCode Created = (# 201, C8.pack "Created" #) +statusCode Accepted = (# 202, C8.pack "Accepted" #) +statusCode NonAuthoritativeInformation = (# 203, C8.pack "Non Authoritative Information" #) +statusCode NoContent = (# 204, C8.pack "No Content" #) +statusCode ResetContent = (# 205, C8.pack "Reset Content" #) +statusCode PartialContent = (# 206, C8.pack "Partial Content" #) +statusCode MultiStatus = (# 207, C8.pack "Multi Status" #) + +statusCode MultipleChoices = (# 300, C8.pack "Multiple Choices" #) +statusCode MovedPermanently = (# 301, C8.pack "Moved Permanently" #) +statusCode Found = (# 302, C8.pack "Found" #) +statusCode SeeOther = (# 303, C8.pack "See Other" #) +statusCode NotModified = (# 304, C8.pack "Not Modified" #) +statusCode UseProxy = (# 305, C8.pack "Use Proxy" #) +statusCode TemporaryRedirect = (# 306, C8.pack "Temporary Redirect" #) + +statusCode BadRequest = (# 400, C8.pack "Bad Request" #) +statusCode Unauthorized = (# 401, C8.pack "Unauthorized" #) +statusCode PaymentRequired = (# 402, C8.pack "Payment Required" #) +statusCode Forbidden = (# 403, C8.pack "Forbidden" #) +statusCode NotFound = (# 404, C8.pack "Not Found" #) +statusCode MethodNotAllowed = (# 405, C8.pack "Method Not Allowed" #) +statusCode NotAcceptable = (# 406, C8.pack "Not Acceptable" #) +statusCode ProxyAuthenticationRequired = (# 407, C8.pack "Proxy Authentication Required" #) +statusCode RequestTimeout = (# 408, C8.pack "Request Timeout" #) +statusCode Conflict = (# 409, C8.pack "Conflict" #) +statusCode Gone = (# 410, C8.pack "Gone" #) +statusCode LengthRequired = (# 411, C8.pack "Length Required" #) +statusCode PreconditionFailed = (# 412, C8.pack "Precondition Failed" #) +statusCode RequestEntityTooLarge = (# 413, C8.pack "Request Entity Too Large" #) +statusCode RequestURITooLarge = (# 414, C8.pack "Request URI Too Large" #) +statusCode UnsupportedMediaType = (# 415, C8.pack "Unsupported Media Type" #) +statusCode RequestRangeNotSatisfiable = (# 416, C8.pack "Request Range Not Satisfiable" #) +statusCode ExpectationFailed = (# 417, C8.pack "Expectation Failed" #) +statusCode UnprocessableEntitiy = (# 422, C8.pack "Unprocessable Entity" #) +statusCode Locked = (# 423, C8.pack "Locked" #) +statusCode FailedDependency = (# 424, C8.pack "Failed Dependency" #) + +statusCode InternalServerError = (# 500, C8.pack "Internal Server Error" #) +statusCode NotImplemented = (# 501, C8.pack "Not Implemented" #) +statusCode BadGateway = (# 502, C8.pack "Bad Gateway" #) +statusCode ServiceUnavailable = (# 503, C8.pack "Service Unavailable" #) +statusCode GatewayTimeout = (# 504, C8.pack "Gateway Timeout" #) +statusCode HttpVersionNotSupported = (# 505, C8.pack "HTTP Version Not Supported" #) +statusCode InsufficientStorage = (# 507, C8.pack "Insufficient Storage" #) \ No newline at end of file diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index a676e15..52f6cf3 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -3,7 +3,7 @@ module Network.HTTP.Lucu.ResponseWriter ) where -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as C8 import Control.Concurrent import Control.Concurrent.STM import Control.Exception @@ -90,7 +90,7 @@ responseWriter cnf h tQueue readerTID else do bodyToSend <- readItr itr itrBodyToSend id - if B.null bodyToSend then + if C8.null bodyToSend then do state <- readItr itr itrState id if state == Done then @@ -132,16 +132,16 @@ responseWriter cnf h tQueue readerTID do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id willChunkBody <- atomically $! readItr itr itrWillChunkBody id chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id - writeItr itr itrBodyToSend B.empty + writeItr itr itrBodyToSend C8.empty return chunk unless willDiscardBody $ do if willChunkBody then - do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk) - hPutStr h "\r\n" - B.hPut h chunk - hPutStr h "\r\n" + do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk) + C8.hPut h (C8.pack "\r\n") + C8.hPut h chunk + C8.hPut h (C8.pack "\r\n") else - B.hPut h chunk + C8.hPut h chunk hFlush h awaitSomethingToWrite @@ -152,7 +152,7 @@ responseWriter cnf 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\r\n" >> hFlush h + $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h finalize :: Interaction -> IO () finalize itr diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index f21e052..00cb337 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -12,9 +12,13 @@ main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } , ( ["inc"] , staticDir "/usr/include" ) ] + fallbacks = [ \ path -> case path of + ["hello"] -> return $ Just helloWorld + _ -> return Nothing + ] in do putStrLn "Access http://localhost:9999/ with your browser." - runHttpd config resources + runHttpd config resources fallbacks helloWorld :: ResourceDef diff --git a/examples/Implanted.hs b/examples/Implanted.hs index 633e40a..390a572 100644 --- a/examples/Implanted.hs +++ b/examples/Implanted.hs @@ -7,5 +7,5 @@ main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } resources = mkResTree [ ([], miseRafturai) ] in do putStrLn "Access http://localhost:9999/ with your browser." - runHttpd config resources + runHttpd config resources [] \ No newline at end of file diff --git a/examples/ImplantedSmall.hs b/examples/ImplantedSmall.hs index 1a65211..9ee3466 100644 --- a/examples/ImplantedSmall.hs +++ b/examples/ImplantedSmall.hs @@ -7,5 +7,5 @@ main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } resources = mkResTree [ ([], smallFile) ] in do putStrLn "Access http://localhost:9999/ with your browser." - runHttpd config resources + runHttpd config resources [] \ No newline at end of file diff --git a/examples/Multipart.hs b/examples/Multipart.hs index b7faa38..e68bb39 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -8,7 +8,7 @@ main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } resources = mkResTree [ ([], resMain) ] in do putStrLn "Access http://localhost:9999/ with your browser." - runHttpd config resources + runHttpd config resources [] resMain :: ResourceDef -- 2.40.0