module Network.Salvia.Impl.Cgi
( CgiHandler (..)
, hCgiEnv
, runCgiHandler
, start
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Record.Label
import Network.Protocol.Http hiding (accept, hostname)
import Network.Salvia.Handlers
import Network.Salvia.Impl.Context
import Network.Salvia.Impl.Handler
import Network.Salvia.Interface
import Network.Socket
import System.Environment
import System.IO
newtype CgiHandler p a = CgiHandler (Handler p a)
deriving
( BodyM Request
, Alternative
, Applicative
, ClientAddressM
, FlushM Request
, FlushM Response
, Functor
, HandleM
, HttpM Request
, HttpM Response
, Monad
, MonadIO
, MonadPlus
, Monoid
, HandleQueueM
, QueueM
, RawHttpM Request
, RawHttpM Response
, SendM
, ForkM IO
, ServerAddressM
, ServerM
)
hCgiEnv :: (FlushM Response m, MonadIO m, QueueM m, HttpM' m, HandleM m) => m a -> m ()
hCgiEnv handler =
do hBanner "salvia-httpd"
_ <- hHead handler
h <- handle
st <- response (getM status)
liftIO $ hPutStr h (intercalate " " ["Status:", show (codeFromStatus st), show st] ++ "\r\n")
hFlushHeadersOnly forResponse
flushQueue forResponse
runCgiHandler :: CgiHandler p a -> Context p -> IO (a, Context p)
runCgiHandler (CgiHandler h) = runHandler h
start :: Show p => String -> CgiHandler p () -> p -> IO ()
start prefix handler pyld =
do env <- getEnvironment
let ur = fromMaybe "" (lookup "REQUEST_URI" env)
qy = maybe "" ('?':) (lookup "QUERY_STRING" env)
mthd = maybe GET methodFromString (lookup "REQUEST_METHOD" env)
prot = maybe http11 versionFromString (lookup "SERVER_PROTOCOL" env)
req = Http (Request mthd (fromMaybe ur (stripPrefix prefix ur) ++ qy)) prot (getHeaders env)
sa <- getAddrInfo Nothing (lookup "SERVER_ADDR" env) (lookup "SERVER_PORT" env)
ca <- getAddrInfo Nothing (lookup "REMOTE_ADDR" env) (lookup "REMOTE_PORT" env)
_ <- runCgiHandler handler
Context
{ _cServerHost = fromMaybe "" (lookup "SERVER_NAME" env)
, _cAdminMail = fromMaybe "" (lookup "SERVER_ADMIN" env)
, _cListenOn = map addrAddress sa
, _cPayload = pyld
, _cRequest = req
, _cResponse = emptyResponse
, _cRawRequest = req
, _cRawResponse = emptyResponse
, _cSocket = error "No socket available in CGI mode."
, _cHandle = stdout
, _cClientAddr = addrAddress (head ca)
, _cServerAddr = addrAddress (head sa)
, _cQueue = []
}
return ()
getHeaders :: [(String, String)] -> Headers
getHeaders =
Headers
. map (\(a, b) -> (norm a, b))
. filter (("HTTP_" `isPrefixOf`) . fst)
where norm = normalizeHeader . replace '_' '-' . fromJust . stripPrefix "HTTP_"
replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)