module Web.Wheb.InitM
(
addGET
, addPOST
, addPUT
, addDELETE
, addRoute
, addRoutes
, catchAll
, addWAIMiddleware
, addWhebMiddleware
, addSetting
, addSetting'
, addSettings
, readSettingsFile
, addCleanupHook
, generateOptions
, genMinOpts
) where
import Control.Concurrent.STM
import Control.Monad.IO.Class
import Control.Monad.Writer
import Data.Char (isSpace)
import qualified Data.Map as M
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
import Data.Typeable
import Network.Wai
import Network.Wai.Handler.Warp (defaultSettings
, settingsOnOpen
, settingsOnClose)
import Network.HTTP.Types.Method
import Text.Read (readMaybe)
import Web.Wheb.Internal
import Web.Wheb.Routes
import Web.Wheb.Types
import Web.Wheb.Utils
addGET :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m ()
addGET n p h = addRoute $ patRoute (Just n) GET p h
addPOST :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m ()
addPOST n p h = addRoute $ patRoute (Just n) POST p h
addPUT :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m ()
addPUT n p h = addRoute $ patRoute (Just n) PUT p h
addDELETE :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m ()
addDELETE n p h = addRoute $ patRoute (Just n) DELETE p h
addRoute :: Route g s m -> InitM g s m ()
addRoute r = addRoutes [r]
addRoutes :: [Route g s m] -> InitM g s m ()
addRoutes rs = InitM $ tell $ mempty { initRoutes = rs }
catchAll :: WhebHandlerT g s m -> InitM g s m ()
catchAll h = addRoute $ Route Nothing (const True) parser h
where parser = UrlParser (const (Just [])) (const (Right $ T.pack "/*"))
addWAIMiddleware :: Middleware -> InitM g s m ()
addWAIMiddleware m = InitM $ tell $ mempty { initWaiMw = m }
addWhebMiddleware :: WhebMiddleware g s m -> InitM g s m ()
addWhebMiddleware m = InitM $ tell $ mempty { initWhebMw = [m] }
addSetting :: T.Text -> T.Text -> InitM g s m ()
addSetting = addSetting'
addSetting' :: Typeable a => T.Text -> a -> InitM g s m ()
addSetting' k v = addSettings $ M.fromList [(k, MkVal v)]
addSettings :: CSettings -> InitM g s m ()
addSettings settings = InitM $ tell $ mempty { initSettings = settings }
readSettingsFile :: FilePath -> InitM g s m ()
readSettingsFile fp = (liftIO $ liftM T.lines (T.readFile fp)) >>= (mapM_ parseLines)
where parseLines line =
case T.splitOn (T.pack ":") line of
a:b:_ -> do
let k = T.strip a
v = T.strip b
maybePutSetting k v (readText :: (T.Text -> Maybe Int))
maybePutSetting k v (readText :: (T.Text -> Maybe Bool))
maybePutSetting k v (readText :: (T.Text -> Maybe Float))
addSetting k v
_ -> return ()
readText :: Read a => T.Text -> Maybe a
readText = readMaybe . T.unpack
maybePutSetting k t parse = maybe (return ()) (addSetting' k) (parse t)
addCleanupHook :: IO () -> InitM g s m ()
addCleanupHook action = InitM $ tell $ mempty { initCleanup = [action] }
generateOptions :: MonadIO m => InitM g s m (g, s) -> IO (WhebOptions g s m)
generateOptions m = do
((g, s), InitOptions {..}) <- runWriterT (runInitM m)
tv <- liftIO $ newTVarIO False
ac <- liftIO $ newTVarIO 0
let warpsettings = defaultSettings
{ settingsOnOpen = atomically (addToTVar ac)
, settingsOnClose = atomically (subFromTVar ac)}
return $ WhebOptions { appRoutes = initRoutes
, runTimeSettings = initSettings
, warpSettings = warpsettings
, startingCtx = g
, startingState = InternalState s M.empty
, waiStack = initWaiMw
, whebMiddlewares = initWhebMw
, defaultErrorHandler = defaultErr
, shutdownTVar = tv
, activeConnections = ac
, cleanupActions = initCleanup }
where addToTVar ac = ((readTVar ac) >>= (\cs -> writeTVar ac (succ cs)))
subFromTVar ac = ((readTVar ac) >>= (\cs -> writeTVar ac (pred cs)))
genMinOpts :: InitM () () IO () -> IO MinOpts
genMinOpts m = generateOptions (m >> (return ((), ())))