Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Adding FastCGI support

  • Loading branch information...
commit 2a93e469dbd2c0799fc854aaa0de94d753b0d698 1 parent 727bbd2
@alsonkemp authored
View
9 Config/App.hs
@@ -3,7 +3,8 @@ module Config.App (
customSetupFilters,
customPreFilters,
customPostFilters,
- logLevel
+ logLevel,
+ maxFCGIThreads
) where
import System.Log.Logger
@@ -45,3 +46,9 @@ customPostFilters = [persistSession sessionOpts]
logLevel = DEBUG -- DEBUG < INFO < NOTICE < WARNING < ERROR < CRITICAL < ALERT < EMERGENCY
+----------------------------------------------------------------
+-- FastCGI
+----------------------------------------------------------------
+maxFCGIThreads :: Int
+maxFCGIThreads = 4
+
View
13 Turbinado/Environment/Response.hs
@@ -16,16 +16,13 @@ import System.Time
import System.Locale
---getResponse :: (HasEnvironment m) => m HTTP.Response
---getResponse = do e <- getEnvironment
--- return $ getResponse e
-
setResponse :: (HasEnvironment m) => HTTP.Response String -> m ()
setResponse resp = do e <- getEnvironment
setEnvironment $ e {getResponse = Just resp}
-isResponseComplete :: Environment -> Bool
-isResponseComplete e = case (getResponse e) of
- Nothing -> False
- Just r' -> (HTTP.rspCode r' /= (0,0,0))
+isResponseComplete :: (HasEnvironment m) => m Bool
+isResponseComplete = do e <- getEnvironment
+ case (getResponse e) of
+ Nothing -> return False
+ Just r' -> return (HTTP.rspCode r' /= (0,0,0))
View
120 Turbinado/Server.hs
@@ -6,10 +6,11 @@ import Control.Monad
import System.IO
import System.Directory
import System.Time
-import System.Environment (getArgs)
+import System.Environment (getArgs, getEnvironment)
import System.Console.GetOpt
import Network hiding (accept)
+import Network.FastCGI
import Network.Socket
import Prelude hiding (catch)
import Data.Dynamic ( fromDynamic )
@@ -20,6 +21,7 @@ import Network.URI
import qualified Network.HTTP as HTTP
import qualified Network.URI as URI
+import Config.App
import Config.Master
import Turbinado.Controller.Monad hiding (catch)
@@ -34,22 +36,24 @@ import Turbinado.Environment.Types
import Turbinado.Environment.ViewData
import Turbinado.Environment.CodeStore (addCodeStoreToEnvironment)
import Turbinado.Server.Exception
-import Turbinado.Server.ErrorHandler (handleError, handleTurbinado)
+import Turbinado.Server.ErrorHandler (handleCGIError, handleCGITurbinado, handleHTTPError, handleHTTPTurbinado)
import Turbinado.Server.RequestProcess (processRequest)
-import Turbinado.Server.Network (receiveRequest, sendResponse)
+import Turbinado.Server.Network (receiveCGIRequest, sendCGIResponse, receiveHTTPRequest, sendHTTPResponse)
import Turbinado.Server.StandardResponse (addEmptyResponse, pageResponse)
import Turbinado.Server.StaticContent
data Flag
- = Port Integer
+ = UseHTTP Integer
| UseCGI
+ | UseFCGI
| Help
deriving (Show, Eq)
options :: [OptDescr Flag]
options =
- [ Option ['p'] ["port"] (ReqArg (Port . read) "PORTNUMBER") "start hsp runtime on port PORTNUMBER"
- , Option ['c'] ["eval"] (NoArg UseCGI) "run as a CGI app"
+ [ Option ['p'] ["port"] (ReqArg (UseHTTP . read) "PORTNUMBER") "start hsp runtime on port PORTNUMBER"
+ , Option ['c'] ["eval"] (NoArg UseCGI) "run as a CGI app"
+ , Option ['f'] ["eval"] (NoArg UseFCGI) "run as an FCGI app"
, Option ['h','?'] ["help"] (NoArg Help) "show this message"
]
@@ -58,90 +62,98 @@ main :: IO ()
main =
do args <- getArgs
case getOpt Permute options args of
- ([Port n],[],[]) -> startServer (fromIntegral n)
- ([UseCGI],[],[]) -> startServer runAsCGIPort
- (opts,[],[]) | Help `elem` opts -> putStr $ usageInfo header options
- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+ ([UseHTTP n],[],[]) -> startServer (UseHTTP n)
+ ([UseFCGI],[],[]) -> startServer (UseFCGI)
+ ([UseCGI],[],[]) -> startServer (UseCGI)
+ (opts,[],[]) -> putStr $ "ERROR: You may only specify one flag.\n\n" ++ usageInfo header options
+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where
header = "Usage: turbinado [OPTION]"
-runAsCGIPort :: PortNumber
-runAsCGIPort = fromIntegral 0
-
-- | Starts the server, builds the basic 'Environment', builds the 'WorkerPool',
-- starts listening on the specified port. As soon as a request is noticed,
-- it's handed off to a 'WorkerThread' to be handled. Lather, Rinse, Repeat.
-startServer :: PortNumber -> IO ()
-startServer pnr
+startServer :: Flag -> IO ()
+startServer using
= withSocketsDo $
do e <- runController
(sequence_ $ [ addLoggerToEnvironment
, addCodeStoreToEnvironment
, addMimeTypesToEnvironment "Config/mime.types"
, addRoutesToEnvironment
+ , addEmptyResponse
+ , addViewDataToEnvironment
+ , addSettingsToEnvironment
]
++ customSetupFilters
)
newEnvironment
- case (pnr == runAsCGIPort) of
- True -> do mainLoop Nothing e Nothing
- False -> do sock <- listenOn $ PortNumber pnr
- workerPoolMVar <- newMVar $ WorkerPool 0 [] []
- mainLoop (Just sock) e (Just workerPoolMVar)
+ case using of
+ UseCGI -> do processCGI (Network.FastCGI.runCGI) e
+ UseFCGI -> do processCGI (Network.FastCGI.runFastCGIConcurrent maxFCGIThreads) e
+ UseHTTP p -> do sock <- listenOn $ PortNumber $ fromIntegral p
+ workerPoolMVar <- newMVar $ WorkerPool 0 [] []
+ httpLoop sock e workerPoolMVar
+ f -> error $ "Flag not supported: " ++ (show f)
where
- --mainLoop :: Socket -> WorkerPool -> IO ()
- mainLoop Nothing e Nothing = -- Run as Server
- do e' <- runController (addDatabaseToEnvironment) e -- need to add DB for this request (rather than per thread)
- workerLoop Nothing e' Nothing
- mainLoop (Just sock) e (Just workerPoolMVar) = -- Run as Server
+ httpLoop sock e workerPoolMVar = -- Run as Server
do (sock', sockAddr) <- accept sock
WorkerThread _ chan <- getWorkerThread workerPoolMVar e
writeChan chan sock'
- mainLoop (Just sock) e (Just workerPoolMVar)
+ httpLoop sock e workerPoolMVar
+
+
+processCGI :: (CGI CGIResult -> IO ()) -> Environment -> IO ()
+processCGI handler e = (handler $
+ do body <- getBody
+ hdrs <- getVars
+ uri <- requestURI
+ method <- requestMethod
+ e' <- liftIO $
+ runController (sequence_ [ addDatabaseToEnvironment
+ , receiveCGIRequest uri method body hdrs
+ , processRequest
+ ]
+ ) e
+ sendCGIResponse e'
+ ) `catchTurbinado` (\ex -> handleCGITurbinado ex e)
+ `catch` (\ex -> handleCGIError ex e)
+
------------------------------------------------
--- | Worker stuff
+-- | Worker stuff used for HTTP processing
------------------------------------------------
-- | The basic loop for a 'WorkerThread': get the socket from the server mainloop,
-- receive a request, handle it, then put myself back into the 'WorkerPool'.
-workerLoop :: Maybe (MVar WorkerPool) ->
+workerLoop :: MVar WorkerPool ->
Environment ->
- Maybe (Chan Socket) ->
+ Chan Socket ->
IO ()
-workerLoop Nothing e Nothing
- = do workerProcessRequest Nothing e
-workerLoop (Just workerPoolMVar) e (Just chan)
+workerLoop workerPoolMVar e chan
= do sock <- readChan chan
- workerProcessRequest (Just sock) e
+ workerProcessRequest sock e
putWorkerThread workerPoolMVar chan
- workerLoop (Just workerPoolMVar) e (Just chan)
-workerLoop _ e _ = error "Turbinado.Server: workerLoop: Not CGI mode and not Server mode."
+ workerLoop workerPoolMVar e chan
-- | Basic request handling: setup the 'Environment' for this request,
-- run the real requestHandler, then ship the response back to the client.
-workerProcessRequest :: Maybe Socket -> Environment -> IO ()
-workerProcessRequest msock e
+workerProcessRequest :: Socket -> Environment -> IO ()
+workerProcessRequest sock e
= (do mytid <- myThreadId
- e' <- runController (sequence_ [ addEmptyResponse
- , addViewDataToEnvironment
- , addSettingsToEnvironment
- , receiveRequest msock
- , tryStaticContent
- ]) e
- case (isResponseComplete e') of
- True -> sendResponse msock e'
- False -> do e'' <- runController processRequest e'
- sendResponse msock e''
+ runController
+ (do receiveHTTPRequest sock
+ tryStaticContent
+ processRequest
+ sendHTTPResponse sock
+ ) e
+ return ()
)
- `catchTurbinado` (\ex -> handleTurbinado msock ex e)
- `catch` (\ex -> handleError msock ex e)
- `finally` (when (isJust msock)
- (sClose $ fromJust msock)
- )
-
+ `catchTurbinado` (\ex -> handleHTTPTurbinado sock ex e)
+ `catch` (\ex -> handleHTTPError sock ex e)
+ `finally` (sClose sock)
------------------------------------------------
@@ -171,7 +183,7 @@ getWorkerThread mv e =
WorkerPool n [] bs ->
do chan <- newChan
e' <- runController (addDatabaseToEnvironment) e
- tid <- forkIO $ workerLoop (Just mv) e' (Just chan)
+ tid <- forkIO $ workerLoop mv e' chan
let workerThread = WorkerThread tid chan
expiresTime <- getCurrentTime >>= \utct -> return $ addUTCTime (fromInteger stdTimeOut) utct
putMVar mv $ WorkerPool (n+1) [] ((workerThread, expiresTime):bs)
View
35 Turbinado/Server/ErrorHandler.hs
@@ -3,6 +3,7 @@ module Turbinado.Server.ErrorHandler where
import System.IO
import Prelude hiding (catch)
import Data.Dynamic ( fromDynamic )
+import Network.FastCGI
import Network.Socket
import Turbinado.Controller.Monad
@@ -11,17 +12,37 @@ import Turbinado.Environment.Response
import Turbinado.Server.Exception
import Turbinado.Server.Network
import Turbinado.Server.StandardResponse
+import Turbinado.Utility.Data
-handleError :: (Maybe Socket) -> Exception -> Environment -> IO ()
-handleError s ex e = do e' <- runController (errorResponse err) e
- sendResponse s e'
+handleHTTPError :: Socket -> Exception -> Environment -> IO ()
+handleHTTPError s ex e =
+ do runController (errorResponse err >> sendHTTPResponse s) e
+ return ()
where err = unlines [ "Error in server: " ++ show ex
," please report as a bug to alson@alsonkemp.com"]
-handleTurbinado :: (Maybe Socket) -> TurbinadoException -> Environment -> IO ()
-handleTurbinado s he e = do
- e' <- runController (case he of
+handleCGIError :: Exception -> Environment -> IO ()
+handleCGIError ex e =
+ do e' <- liftIO $ runController (errorResponse err) e
+ runFastCGIorCGI $ sendCGIResponse e'
+ where err = unlines [ "Error in server: " ++ show ex
+ ," please report as a bug to alson@alsonkemp.com"]
+
+
+handleHTTPTurbinado :: Socket -> TurbinadoException -> Environment -> IO ()
+handleHTTPTurbinado s he e = do
+ e' <- buildResponse he e
+ runController (sendHTTPResponse s) e'
+ return ()
+
+handleCGITurbinado :: TurbinadoException -> Environment -> IO ()
+handleCGITurbinado he e = do
+ e' <- liftIO $ buildResponse he e
+ runFastCGIorCGI $ sendCGIResponse e'
+
+buildResponse he e = runController (
+ case he of
CompilationFailed errs -> errorResponse err
where err = unlines $ "File did not compile:" : errs
FileNotFound file -> fileNotFoundResponse file
@@ -41,4 +62,4 @@ handleTurbinado s he e = do
Nothing -> show ex
Just hspe -> show hspe
_ -> show ex) e
- sendResponse s e'
+
View
46 Turbinado/Server/Network.hs
@@ -1,10 +1,13 @@
module Turbinado.Server.Network (
- receiveRequest -- :: Handle -> IO Request
- , sendResponse -- :: Handle -> Response -> IO ()
+ receiveHTTPRequest
+ , sendHTTPResponse
+ , receiveCGIRequest
+ , sendCGIResponse
) where
import Data.Maybe
import Network.Socket
+import Network.FastCGI
import Network.HTTP hiding (receiveHTTP, respondHTTP)
import Network.HTTP.Stream
import Network.StreamSocket
@@ -24,10 +27,8 @@ import Turbinado.Utility.Data
-- | Read the request from client.
-receiveRequest :: Maybe Socket -> Controller ()
-receiveRequest Nothing = do e <- getEnvironment
- acceptCGI
-receiveRequest (Just sock) = do
+receiveHTTPRequest :: Socket -> Controller ()
+receiveHTTPRequest sock = do
req <- liftIO $ receiveHTTP sock
case req of
Left e -> throwTurbinado $ BadRequest $ "In receiveRequest : " ++ show e
@@ -36,29 +37,23 @@ receiveRequest (Just sock) = do
-- | Get the 'Response' from the 'Environment' and send
-- it back to the client.
-sendResponse :: Maybe Socket -> Environment -> IO ()
-sendResponse Nothing e = respondCGI $ fromJust' "Network : sendResponse" $ Turbinado.Environment.Types.getResponse e
-sendResponse (Just sock) e = do
- respondHTTP sock $ fromJust' "Network : sendResponse" $ Turbinado.Environment.Types.getResponse e
+sendHTTPResponse :: Socket -> Controller ()
+sendHTTPResponse sock = do e <- getEnvironment
+ liftIO $ respondHTTP sock $ fromJust' "Network : sendResponse" $ Turbinado.Environment.Types.getResponse e
-- | Pull a CGI request from stdin
-acceptCGI :: Controller ()
-acceptCGI = do body <- liftIO $ hGetContents stdin
- hdrs <- liftIO $ Env.getEnvironment
- let rqheaders = parseHeaders $ extractHTTPHeaders hdrs
- rquri = fromJust' "Network: acceptCGI: parseURI failed" $ parseURI $
- fromJust' "Network: acceptCGI: No REQUEST_URI in hdrs" $ lookup "SCRIPT_URI" hdrs
- rqmethod = fromJust' "Network: acceptCGI: REQUEST_METHOD invalid" $ flip lookup rqMethodMap $
- fromJust' "Network: acceptCGI: No REQUEST_METHOD in hdrs" $ lookup "REQUEST_METHOD" hdrs
+receiveCGIRequest :: URI -> String -> String -> [(String, String)] -> Controller ()
+receiveCGIRequest rquri rqmethod rqbody hdrs =
+ do let rqheaders = parseHeaders $ extractHTTPHeaders hdrs
case rqheaders of
Left err -> errorResponse $ show err
Right r -> do e' <- getEnvironment
setEnvironment $ e' {
Turbinado.Environment.Types.getRequest =
Just Request { rqURI = rquri
- , rqMethod = rqmethod
+ , rqMethod = matchRqMethod rqmethod
, rqHeaders = r
- , rqBody = body
+ , rqBody = rqbody
}
}
@@ -72,10 +67,13 @@ matchRqMethod m = fromJust' "Turbinado.Server.Network:matchRqMethod" $
]
-- | Convert the HTTP.Response to a CGI response for stdout.
-respondCGI :: Response String -> IO ()
-respondCGI r = do let message = (unlines $ drop 1 $ lines $ show r) ++ "\n\n" ++ rspBody r -- need to drop the first line from the response for CGI
- hPutStr stdout message
- hFlush stdout
+sendCGIResponse :: Environment -> CGI CGIResult
+sendCGIResponse e = do let r = fromJust' "Network: respondCGI: getResponse failed" $ getResponse e
+ (c1,c2,c3) = rspCode r
+ message = (unlines $ drop 1 $ lines $ show r) ++ "\n\n" ++ rspBody r -- need to drop the first line from the response for CGI
+ mapM_ (\(Header k v) -> setHeader (show k) v) $ rspHeaders r
+ setStatus (100*c1+10*c2+c3) (rspReason r)
+ output $ rspBody r
-- | Convert from HTTP_SOME_FLAG to Some-Flag for HTTP.parseHeaders
extractHTTPHeaders :: [(String, String)] -> [String]
View
31 Turbinado/Server/RequestProcess.hs
@@ -61,16 +61,21 @@ postFilters = []
-- then runs the Controller and View.
processRequest :: Controller ()
processRequest = do
- debugM $ " requestHandler : running pre and main filters"
- -- Run the Pre filters, the page
- sequence_ $ preFilters ++
- customPreFilters ++
- [ retrieveAndRunController
- , checkFormats
- , retrieveAndRunLayout
- ]
- debugM $ " requestHandler : running post filters"
- sequence_ (customPostFilters ++ postFilters)
+ debugM $ " requestHandler : checking to see if the response is complete"
+ complete <- isResponseComplete
+ case complete of
+ True -> do debugM $ " processRequest : response was already complete"
+ return ()
+ False -> do debugM $ " requestHandler : running pre and main filters"
+ -- Run the Pre filters, the page
+ sequence_ $ preFilters ++
+ customPreFilters ++
+ [ retrieveAndRunController
+ , checkFormats
+ , retrieveAndRunLayout
+ ]
+ debugM $ " requestHandler : running post filters"
+ sequence_ (customPostFilters ++ postFilters)
-- | This function dynamically loads (if needed) the 'Controller'
@@ -80,7 +85,8 @@ retrieveAndRunController :: Controller ()
retrieveAndRunController =
do debugM $ " retrieveAndRunController : Starting"
e <- getEnvironment
- case (isResponseComplete e) of
+ complete <- isResponseComplete
+ case complete of
True -> do debugM $ " retrieveAndRunController : response was already complete"
return ()
False -> do co <- getController
@@ -101,7 +107,8 @@ retrieveAndRunController =
retrieveAndRunLayout :: Controller ()
retrieveAndRunLayout =
do e <- getEnvironment
- case (isResponseComplete e) of
+ complete <- isResponseComplete
+ case complete of
True -> do debugM $ " retrieveAndRunLayout : response was already complete"
return ()
False -> do l <- getSetting "layout"
View
8 static/dispatch.fcgi
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# mod_fastcgi doesn't export many environment variables
+# so PATH must be explicitly exported.
+export PATH=/usr/local/bin:/usr/bin:/bin
+
+cd ..
+dist/build/turbinado/turbinado -f
View
6 turbinado.cabal
@@ -12,11 +12,13 @@ Cabal-Version: >= 1.6
Executable turbinado
Main-is: Turbinado/Main.hs
+ ghc-options: -threaded
Build-Depends: base >= 4,
containers,
Crypto > 4.1.0,
dataenc,
directory,
+ fastcgi,
filepath,
HDBC >= 2,
HDBC-odbc >= 2,
@@ -46,12 +48,10 @@ Executable turbinado
EmptyDataDecls,
CPP,
TypeSynonymInstances,
- OverlappingInstances,
- UndecidableInstances,
PatternGuards,
MultiParamTypeClasses,
ScopedTypeVariables,
- DeriveDataTypeable
+ UndecidableInstances
-- Creating a Library mostly in order to make documentation.
Library
Please sign in to comment.
Something went wrong with that request. Please try again.