+-- | Lucu is an HTTP daemonic library. It can be embedded in any
+-- Haskell program and runs in an independent thread.
+--
+-- Features:
+--
+-- [/Full support of HTTP\/1.1/] Lucu supports request pipelining,
+-- chunked I\/O, ETag comparison and \"100 Continue\".
+--
+-- [/Performance/] Lucu doesn't fork\/exec to handle requests like
+-- CGI. It just spawns a new thread. Inter-process communication is
+-- done with STM.
+--
+-- Lucu is not a replacement for Apache. It is intended to be used to
+-- create an efficient web-based application without messing around
+-- FastCGI. It is also intended to be run behind a reverse-proxy so it
+-- doesn't have the following (otherwise essential) facilities:
+--
+-- [/Logging/] Lucu doesn't log any requests from any clients.
+--
+-- [/Client Filtering/] Lucu always accept any clients. No IP filter
+-- is implemented.
+--
+-- [/SSL Support/] Lucu can handle HTTP only.
+--
+-- [/Bandwidth Limitting/] Lucu doesn't limit bandwidth it consumes.
+--
+-- [/Protection Against Wicked Clients/] Lucu is fragile against
+-- wicked clients. No attacker should cause a buffer-overflow but
+-- can possibly DoS it.
+--
+
+
module Network.HTTP.Lucu
- ( -- Abortion
- abort
- , abortA
+ ( -- * Entry Point
+ runHttpd
- -- Config
+ -- * Configuration
, module Network.HTTP.Lucu.Config
- -- ETag
+ -- * Resource Tree
+ , ResourceDef(..)
+ , ResTree
+ , mkResTree
+
+ -- * Resource Monad
+ , module Network.HTTP.Lucu.Resource
+
+ -- ** Things to be used in the Resource monad
+
+ -- *** Status Code
+ , StatusCode(..)
+
+ -- *** Abortion
+ , abort
+ , abortA
+
+ -- *** ETag
, ETag(..)
, strongETag
, weakETag
- -- Httpd
- , runHttpd
-
- -- MIMEType
+ -- *** MIME Type
, MIMEType(..)
, (</>)
, (<:>)
, (<=>)
- -- Resource (driftTo だけは要らない)
- , module Network.HTTP.Lucu.Resource
+ -- * Utility
- -- Resource.Tree
- , ResourceDef(..)
- , ResTree
- , mkResTree
-
- -- Response
- , StatusCode(..)
-
- -- StaticFile
+ -- ** Static file handling
, module Network.HTTP.Lucu.StaticFile
)
where
+-- #prune
+
+-- | Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
+-- in any IO monads or arrows.
module Network.HTTP.Lucu.Abortion
( Abortion(..)
, abort
, aboMessage :: Maybe String
} deriving (Show, Typeable)
-
+-- | Computation of @'abort' status headers msg@ aborts the
+-- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
+-- additional response headers, and optional message string.
+--
+-- What this really does is to just throw a special DynException. The
+-- exception will be caught by the system.
+--
+-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
+-- Header/ or any precedent states, it is possible to use the
+-- @status@ and such like as a HTTP response to be sent to the
+-- client.
+--
+-- 2. Otherwise the HTTP response can't be modified anymore so the
+-- only possible thing the system can do is to dump it to the
+-- stderr. See
+-- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
+--
+-- Note that the status code doesn't have to be an error code so you
+-- can use this action for redirection as well as error reporting e.g.
+--
+-- > abort MovedPermanently
+-- > [("Location", "http://example.net/")]
+-- > (Just "It has been moved to example.net")
abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
abort status headers msg
= let abo = Abortion status headers msg
in
liftIO $ throwIO exc
-
+-- | Computation of @'abortSTM' status headers msg@ just computes
+-- 'abort' in a STM monad.
abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
abortSTM status headers msg
= unsafeIOToSTM $ abort status headers msg
-
+-- | Computation of @'abortA' -< (status, (headers, msg))@ just
+-- computes 'abort' in an ArrowIO.
abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
abortA
= arrIO3 abort
import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
import System.IO.Unsafe
--- |A configuration record for the Lucu httpd. You need to use
+-- |Configuration record for the Lucu httpd. You need to use
-- 'defaultConfig' or setup your own configuration to run the httpd.
data Config = Config {
-- |A string which will be sent to clients as \"Server\" field.
- cnfServerSoftware :: String
+ cnfServerSoftware :: String
-- |The host name of the server. This value will be used in
-- built-in pages like \"404 Not Found\".
- , cnfServerHost :: HostName
+ , cnfServerHost :: HostName
-- |A port ID to listen to HTTP clients.
- , cnfServerPort :: PortID
+ , cnfServerPort :: PortID
-- |The maximum number of requests to accept in one connection
-- simultaneously. If a client exceeds this limitation, its last
-- request won't be processed until a response for its earliest
-- pending request is sent back to the client.
- , cnfMaxPipelineDepth :: Int
+ , cnfMaxPipelineDepth :: Int
-- |The maximum length of request entity to accept in bytes. Note
-- that this is nothing but the default value which is used when
-- 'Network.HTTP.Lucu.Resource.input' and such like are applied to
-- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no
-- guarantee that this value always constrains all the requests.
- , cnfMaxEntityLength :: Int
+ , cnfMaxEntityLength :: Int
-- |The maximum length of chunk to output. This value is used by
-- 'Network.HTTP.Lucu.Resource.output' and such like to limit the
-- chunk length so you can safely output an infinite string (like
-- a lazy stream of \/dev\/random) using those actions.
, cnfMaxOutputChunkLength :: Int
+ -- | Whether to dump too late abortion to the stderr or not. See
+ -- 'Network.HTTP.Lucu.Abortion.abort'.
+ , cnfDumpTooLateAbortionToStderr :: Bool
-- |A mapping from extension to MIME Type. This value is used by
-- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME
-- Type of static files. Note that MIME Types are currently
-- a good idea to use GnomeVFS
-- (<http://developer.gnome.org/doc/API/2.0/gnome-vfs-2.0/>)
-- instead of vanilla FS.
- , cnfExtToMIMEType :: ExtMap
+ , cnfExtToMIMEType :: ExtMap
}
-- |The default configuration. Generally you can use this value as-is,
-- 'cnfServerPort'.
defaultConfig :: Config
defaultConfig = Config {
- cnfServerSoftware = "Lucu/1.0"
- , cnfServerHost = unsafePerformIO getHostName
- , cnfServerPort = Service "http"
- , cnfMaxPipelineDepth = 100
- , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
- , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB
- , cnfExtToMIMEType = defaultExtensionMap
+ cnfServerSoftware = "Lucu/1.0"
+ , cnfServerHost = unsafePerformIO getHostName
+ , cnfServerPort = Service "http"
+ , cnfMaxPipelineDepth = 100
+ , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
+ , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB
+ , cnfDumpTooLateAbortionToStderr = True
+ , cnfExtToMIMEType = defaultExtensionMap
}
+-- | The entry point of Lucu httpd.
module Network.HTTP.Lucu.Httpd
- ( runHttpd -- Config -> ResTree -> IO ()
+ ( runHttpd
)
where
import Control.Concurrent
-import Control.Concurrent.STM
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
import Network
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.RequestReader
-import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.ResponseWriter
-import System.IO
-
+import System.Posix.Signals
+-- | This is the entry point of Lucu httpd. It listens to a socket and
+-- waits for clients. Computation of 'runHttpd' never stops by itself
+-- so the only way to stop it is to raise an exception in the thread
+-- computing it.
+--
+-- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
+-- computing @installHandler sigPIPE Ignore Nothing@. This can hardly
+-- cause a problem but it may do.
+--
+-- Example:
+--
+-- > module Main where
+-- > import Network.HTTP.Lucu
+-- >
+-- > main :: IO ()
+-- > main = let config = defaultConfig
+-- > resources = mkResTree [ ([], helloWorld) ]
+-- > in
+-- > runHttpd config resourcees
+-- >
+-- > helloWorld :: ResourceDef
+-- > helloWorld = ResourceDef {
+-- > resUsesNativeThread = False
+-- > , resIsGreedy = False
+-- > , resGet
+-- > = Just $ do setContentType $ "text" </> "plain"
+-- > output "Hello, world!"
+-- > , resHead = Nothing
+-- > , resPost = Nothing
+-- > , resPut = Nothing
+-- > , resDelete = Nothing
+-- > }
runHttpd :: Config -> ResTree -> IO ()
-runHttpd cnf table
+runHttpd cnf tree
= withSocketsDo $
- do so <- listenOn (cnfServerPort cnf)
+ do installHandler sigPIPE Ignore Nothing
+ so <- listenOn (cnfServerPort cnf)
loop so
where
loop :: Socket -> IO ()
loop so
= do (h, host, _) <- accept so
tQueue <- newInteractionQueue
- readerTID <- forkIO $ requestReader cnf table h host tQueue
+ readerTID <- forkIO $ requestReader cnf tree h host tQueue
writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
loop so
+-- #prune
+
+-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
( ResourceDef(..)
, ResTree
-- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
-- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
-- 無視される。
+
+-- | 'ResourceDef' is basically a set of
+-- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
data ResourceDef = ResourceDef {
+ -- | Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
+ -- native thread (spawned using @forkOS@) or to run it on a user
+ -- thread (spanwed using @forkIO@). Generally you don't
resUsesNativeThread :: Bool
+ -- | Whether to be greedy or not.
+ --
+ -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
+ -- 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.
, resIsGreedy :: Bool
+ -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
+ -- request comes for the resource path. If 'resGet' is Nothing,
+ -- the system responds \"405 Method Not Allowed\" for GET
+ -- requests.
+ --
+ -- It also runs for HEAD request if the 'resHead' is Nothing. In
+ -- this case 'Network.HTTP.Lucu.Resource.output' and such like
+ -- don't actually write a response body.
, resGet :: Maybe (Resource ())
+ -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
+ -- request comes for the resource path. If 'resHead' is Nothing,
+ -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
+ -- the system responds \"405 Method Not Allowed\" for HEAD
+ -- requests.
, resHead :: Maybe (Resource ())
+ -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
+ -- request comes for the resource path. If 'resPost' is Nothing,
+ -- the system responds \"405 Method Not Allowed\" for POST
+ -- requests.
, resPost :: Maybe (Resource ())
+ -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
+ -- request comes for the resource path. If 'resPut' is Nothing,
+ -- the system responds \"405 Method Not Allowed\" for PUT
+ -- requests.
, resPut :: Maybe (Resource ())
+ -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
+ -- DELETE request comes for the resource path. If 'resDelete' is
+ -- Nothing, the system responds \"405 Method Not Allowed\" for
+ -- DELETE requests.
, resDelete :: Maybe (Resource ())
}
+
+-- | 'ResTree' is an opaque structure which is a map from resource
+-- path to 'ResourceDef'.
type 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 [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
+-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
+-- ]
+-- @
mkResTree :: [ ([String], ResourceDef) ] -> ResTree
mkResTree list = processRoot list
where
mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
output $ abortPage conf reqM res abo
else
- hPutStrLn stderr $ show abo
+ when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
+ $ hPutStrLn stderr $ show abo
flip runReaderT itr $ driftTo Done
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.StaticFile
import Network.URI
-import System.Posix.Signals
import System.Time
main :: IO ()
, staticDir "/usr/include" )
]
in
- do installHandler sigPIPE Ignore Nothing
- runHttpd config resources
+ runHttpd config resources
helloWorld :: ResourceDef
projects / Lucu.git / commitdiff