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
+= 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"
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")
)
where
+import qualified Data.ByteString.Char8 as C8
import Network.HTTP.Lucu.Parser
import System.IO
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
--- | The entry point of Lucu httpd.
+-- |The entry point of Lucu httpd.
module Network.HTTP.Lucu.Httpd
- ( runHttpd
+ ( FallbackHandler
+ , runHttpd
)
where
-- > main = let config = defaultConfig
-- > resources = mkResTree [ ([], helloWorld) ]
-- > in
--- > runHttpd config resourcees
+-- > runHttpd config resourcees []
-- >
-- > helloWorld :: ResourceDef
-- > helloWorld = ResourceDef {
-- > , 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
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)
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
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
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 ())
module Network.HTTP.Lucu.Resource.Tree
( ResourceDef(..)
, ResTree
+ , FallbackHandler
+
, mkResTree -- [ ([String], ResourceDef) ] -> ResTree
, findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
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" のリソースが貪欲でなければ、それは
-- 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,
, 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\" ) -- \/
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
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)
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
)
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
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 {
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
-- |@'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
)
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
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
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
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
, ( ["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
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
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
resources = mkResTree [ ([], resMain) ]
in
do putStrLn "Access http://localhost:9999/ with your browser."
- runHttpd config resources
+ runHttpd config resources []
resMain :: ResourceDef
projects / Lucu.git / commitdiff