module Web.Wheb.WhebT
(
getApp
, getWithApp
, getHandlerState
, putHandlerState
, modifyHandlerState
, modifyHandlerState'
, setHeader
, setRawHeader
, html
, text
, file
, builder
, redirect
, throwRedirect
, getSetting
, getSetting'
, getSetting''
, getSettings
, getRouteParams
, getRouteParam
, getRoute
, getRoute'
, getRawRoute
, getRequest
, getRequestHeader
, getWithRequest
, getQueryParams
, getPOSTParam
, getPOSTParams
, getRawPOST
, runWhebServer
, runWhebServerT
, runRawHandler
, runRawHandlerT
) where
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, readTVar, newTVarIO, writeTVar)
import Control.Monad.Except (liftM, MonadError(throwError), MonadIO)
import Control.Monad.Reader (MonadReader(ask))
import Control.Monad.State (modify, MonadState(get))
import qualified Data.ByteString.Lazy as LBS (ByteString, empty)
import Data.CaseInsensitive (mk)
import Data.List (find)
import qualified Data.Map as M (insert, lookup)
import Data.Maybe (fromMaybe)
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TS (decodeUtf8, encodeUtf8)
import qualified Data.Text.Lazy as T
import Data.Typeable (cast, Typeable)
import Network.HTTP.Types.Header (Header)
import Network.HTTP.Types.Status (serviceUnavailable503, status200, status302)
import Network.HTTP.Types.URI (Query)
import Network.Wai (defaultRequest, Request(queryString, requestHeaders), responseLBS)
import Network.Wai.Handler.Warp as W (runSettings, setPort)
import Network.Wai.Parse (File, Param)
import System.Posix.Signals (Handler(Catch), installHandler, sigINT, sigTERM)
import Web.Wheb.Internal (optsToApplication, runDebugHandler)
import Web.Wheb.Routes (generateUrl, getParam)
import Web.Wheb.Types
getApp :: Monad m => WhebT g s m g
getApp = WhebT $ liftM globalCtx ask
getWithApp :: Monad m => (g -> a) -> WhebT g s m a
getWithApp = flip liftM getApp
getHandlerState :: Monad m => WhebT g s m s
getHandlerState = WhebT $ liftM reqState get
putHandlerState :: Monad m => s -> WhebT g s m ()
putHandlerState s = WhebT $ modify (\is -> is {reqState = s})
modifyHandlerState :: Monad m => (s -> s) -> WhebT g s m s
modifyHandlerState f = do
s <- liftM f getHandlerState
putHandlerState s
return s
modifyHandlerState' :: Monad m => (s -> s) -> WhebT g s m ()
modifyHandlerState' f = modifyHandlerState f >> (return ())
getSetting :: Monad m => TS.Text -> WhebT g s m (Maybe T.Text)
getSetting = getSetting'
getSetting' :: (Monad m, Typeable a) => TS.Text -> WhebT g s m (Maybe a)
getSetting' k = liftM (\cs -> (M.lookup k cs) >>= unwrap) getSettings
where unwrap :: Typeable a => SettingsValue -> Maybe a
unwrap (MkVal a) = cast a
getSetting'' :: (Monad m, Typeable a) => TS.Text -> a -> WhebT g s m a
getSetting'' k d = liftM (fromMaybe d) (getSetting' k)
getSettings :: Monad m => WhebT g s m CSettings
getSettings = WhebT $ liftM (runTimeSettings . globalSettings) ask
getRouteParams :: Monad m => WhebT g s m RouteParamList
getRouteParams = WhebT $ liftM routeParams ask
getRouteParam :: (Typeable a, Monad m) => TS.Text -> WhebT g s m a
getRouteParam t = do
p <- getRouteParam' t
maybe (throwError RouteParamDoesNotExist) return p
getRouteParam' :: (Typeable a, Monad m) => TS.Text -> WhebT g s m (Maybe a)
getRouteParam' t = liftM (getParam t) getRouteParams
getRoute :: Monad m => TS.Text -> RouteParamList -> WhebT g s m TS.Text
getRoute name l = do
res <- getRoute' name l
case res of
Right t -> return t
Left err -> throwError $ URLError name err
getRoute' :: Monad m => TS.Text ->
RouteParamList ->
WhebT g s m (Either UrlBuildError TS.Text)
getRoute' n l = liftM buildRoute (getRawRoute n l)
where buildRoute (Just (Route {..})) = generateUrl routeParser l
buildRoute (Nothing) = Left UrlNameNotFound
getRawRoute :: Monad m => TS.Text ->
RouteParamList ->
WhebT g s m (Maybe (Route g s m))
getRawRoute n _ = WhebT $ liftM f ask
where findRoute (Route {..}) = fromMaybe False (fmap (==n) routeName)
f = ((find findRoute) . appRoutes . globalSettings)
getRequest :: Monad m => WhebT g s m Request
getRequest = WhebT $ liftM request ask
getWithRequest :: Monad m => (Request -> a) -> WhebT g s m a
getWithRequest = flip liftM getRequest
getRawPOST :: MonadIO m => WhebT g s m ([Param], [File LBS.ByteString])
getRawPOST = WhebT $ liftM postData ask
getPOSTParams :: MonadIO m => WhebT g s m [(TS.Text, TS.Text)]
getPOSTParams = liftM (fmap f . fst) getRawPOST
where f (a, b) = (TS.decodeUtf8 a, TS.decodeUtf8 b)
getPOSTParam :: MonadIO m => TS.Text -> WhebT g s m (Maybe TS.Text)
getPOSTParam k = liftM (lookup k) getPOSTParams
getQueryParams :: Monad m => WhebT g s m Query
getQueryParams = getWithRequest queryString
getRequestHeader :: Monad m => TS.Text -> WhebT g s m (Maybe TS.Text)
getRequestHeader k = getRequest >>= f
where hk = mk $ TS.encodeUtf8 k
f = (return . (fmap TS.decodeUtf8) . (lookup hk) . requestHeaders)
setRawHeader :: Monad m => Header -> WhebT g s m ()
setRawHeader (hn, hc) = WhebT $ modify insertHeader
where insertHeader is@(InternalState {..}) =
is { respHeaders = M.insert hn hc respHeaders }
setHeader :: Monad m => TS.Text -> TS.Text -> WhebT g s m ()
setHeader hn hc = setRawHeader (mk $ TS.encodeUtf8 hn, TS.encodeUtf8 hc)
file :: Monad m => TS.Text -> TS.Text -> WhebHandlerT g s m
file fp ct = do
setHeader (TS.pack "Content-Type") (ct)
return $ HandlerResponse status200 (WhebFile fp)
html :: Monad m => T.Text -> WhebHandlerT g s m
html c = do
setHeader (TS.pack "Content-Type") (TS.pack "text/html")
return $ HandlerResponse status200 c
text :: Monad m => T.Text -> WhebHandlerT g s m
text c = do
setHeader (TS.pack "Content-Type") (TS.pack "text/plain")
return $ HandlerResponse status200 c
builder :: Monad m => TS.Text -> Builder -> WhebHandlerT g s m
builder c b = do
setHeader (TS.pack "Content-Type") c
return $ HandlerResponse status200 b
redirect :: Monad m => TS.Text -> WhebHandlerT g s m
redirect c = do
setHeader (TS.pack "Location") c
return $ HandlerResponse status302 T.empty
throwRedirect :: Monad m => TS.Text -> WhebHandlerT g s m
throwRedirect c = do
setHeader (TS.pack "Location") c
throwError $ ErrorStatus status302 T.empty
runRawHandlerT :: WhebOptions g s m ->
(m (Either WhebError a) -> IO (Either WhebError a)) ->
Request ->
WhebT g s m a ->
IO (Either WhebError a)
runRawHandlerT opts@(WhebOptions {..}) runIO r h =
runIO $ runDebugHandler opts h baseData
where baseData = HandlerData startingCtx r ([], []) [] opts
runRawHandler :: WhebOptions g s IO ->
WhebT g s IO a ->
IO (Either WhebError a)
runRawHandler opts h = runRawHandlerT opts id defaultRequest h
runWhebServerT :: (forall a . m a -> IO a) ->
WhebOptions g s m ->
IO ()
runWhebServerT runIO opts@(WhebOptions {..}) = do
putStrLn $ "Now running on port " ++ (show $ port)
forceTVar <- newTVarIO False
installHandler sigINT catchSig Nothing
installHandler sigTERM catchSig Nothing
forkIO $ runSettings rtSettings $
gracefulExit $
waiStack $
optsToApplication opts runIO
let termSig = (Catch (atomically $ writeTVar forceTVar True >> writeTVar shutdownTVar True))
installForceKill = installHandler sigTERM termSig Nothing >> installHandler sigINT termSig Nothing
loop installForceKill
putStrLn $ "Waiting for connections to close..."
waitForConnections forceTVar
putStrLn $ "Shutting down server..."
sequence_ cleanupActions
where catchSig = (Catch (atomically $ writeTVar shutdownTVar True))
loop terminate = do
shutDown <- atomically $ readTVar shutdownTVar
if shutDown then terminate else (threadDelay 100000) >> loop terminate
gracefulExit app r respond = do
isExit <- atomically $ readTVar shutdownTVar
case isExit of
False -> app r respond
True -> respond $ responseLBS serviceUnavailable503 [] LBS.empty
waitForConnections forceTVar = do
openConnections <- atomically $ readTVar activeConnections
force <- atomically $ readTVar forceTVar
if (openConnections == 0 || force)
then return ()
else waitForConnections forceTVar
port = fromMaybe 3000 $
(M.lookup (TS.pack "port") runTimeSettings) >>= (\(MkVal m) -> cast m)
rtSettings = W.setPort port warpSettings
runWhebServer :: (WhebOptions g s IO) -> IO ()
runWhebServer = runWhebServerT id