Wheb 0.1.0.0 → 0.2.0.0
raw patch · 12 files changed
+340/−275 lines, 12 filesdep +wai-websocketsdep +web-routesdep +websocketsdep −conduitdep ~Whebdep ~basedep ~case-insensitive
Dependencies added: wai-websockets, web-routes, websockets
Dependencies removed: conduit
Dependency ranges changed: Wheb, base, case-insensitive, mtl, text, transformers, unix, wai, wai-extra, warp
Files
- Wheb.cabal +33/−27
- src/Web/Wheb.hs +13/−8
- src/Web/Wheb/Cookie.hs +11/−14
- src/Web/Wheb/InitM.hs +42/−33
- src/Web/Wheb/Internal.hs +61/−39
- src/Web/Wheb/Plugins/Auth.hs +7/−14
- src/Web/Wheb/Plugins/Debug/MemoryBackend.hs +8/−9
- src/Web/Wheb/Plugins/Session.hs +9/−11
- src/Web/Wheb/Routes.hs +30/−13
- src/Web/Wheb/Types.hs +43/−34
- src/Web/Wheb/Utils.hs +20/−20
- src/Web/Wheb/WhebT.hs +63/−53
Wheb.cabal view
@@ -1,25 +1,27 @@ name: Wheb-version: 0.1.0.0+version: 0.2.0.0 synopsis: The frictionless WAI Framework license: BSD3 license-file: LICENSE author: Kyle Hanson homepage: https://github.com/hansonkd/Wheb-Framework-maintainer: hanooter@gmail.com+maintainer: me@khanson.io category: Web build-type: Simple cabal-version: >=1.10 description: - Wheb's a framework for building robust high concurrency web applications simply and effectively.+ Wheb's a framework for building robust, high-concurrency web applications simply and effectively. . * The core datatype will let you build anything from a read-only server to a fully interactive web application with basic Haskell. . * Minimal boilerplate to start your application. .- * Named routes and URL generation (though it was a trade-off between named and type-safe urls).+ * Typesafe web-routes or named routes and URL generation. . * Easy to use for REST APIs .+ * WebSockets+ . * Fully database and template agnostic . * Easy handler debugging.@@ -41,6 +43,8 @@ . * <http://hackage.haskell.org/package/wheb-mongo Wheb-Mongo> .+ * <http://hackage.haskell.org/package/wheb-strapped Wheb-Strapped>+ . /Wheb in action:/ . > import Web.Wheb@@ -109,39 +113,41 @@ default-language: Haskell2010 exposed-modules: Web.Wheb, Web.Wheb.Cookie, Web.Wheb.InitM, Web.Wheb.Internal, Web.Wheb.Routes, Web.Wheb.Types, Web.Wheb.Utils, Web.Wheb.WhebT, Web.Wheb.Plugins.Auth, Web.Wheb.Plugins.Session, Web.Wheb.Plugins.Debug.MemoryBackend - build-depends: base ==4.6.*, - text ==0.11.*, - transformers ==0.3.*, - wai-extra ==2.0.*, - time ==1.4.*, - bytestring ==0.10.*, - blaze-builder ==0.3.*, - cookie ==0.4.*, - mtl ==2.1.*, - containers ==0.5.*, - wai ==2.0.*, - http-types ==0.8.*, - warp ==2.0.*, - conduit ==1.0.*, - case-insensitive ==1.0.*, - pwstore-fast ==2.4.*, - transformers ==0.3.*,- uuid ==1.3.*, - stm ==2.4.*, - unix ==2.6.*+ build-depends: base >= 4.7 && < 4.8, + text >= 1.0 && < 1.2, + transformers >= 0.4 && < 0.5, + time >=1.4 && < 1.5, + bytestring >= 0.10 && < 0.11, + blaze-builder >=0.3 && < 0.4, + cookie >=0.4 && < 0.5, + mtl >=2.1 && < 2.3, + containers >=0.5 && <0.6, + wai >= 3.0 && < 3.1, + warp >= 3.0 && < 3.1, + wai-extra >= 3.0 && < 3.1, + http-types >=0.8 && <0.9, + case-insensitive >=1.2 && < 1.3, + pwstore-fast >=2.4 && < 2.5, + uuid >=1.3 && < 1.4, + stm >=2.4 && < 2.5, + unix >= 2.7 && < 2.8,+ web-routes >=0.27 && <0.28,+ websockets >= 0.8 && <0.9,+ wai-websockets >= 3.0 && < 3.1+ hs-source-dirs: src GHC-options: -Wall -fno-warn-orphans test-suite Main type: exitcode-stdio-1.0- build-depends: Wheb ==0.1.*,- base ==4.6.*, + build-depends: Wheb ==0.2.*,+ base ==4.7.*, HUnit >= 1.2 && < 2, QuickCheck >= 2.4, test-framework >= 0.4.1, test-framework-quickcheck2, test-framework-hunit,- text ==0.11.*+ text >= 1.0 && < 1.2 ghc-options: -Wall -rtsopts hs-source-dirs: tests
src/Web/Wheb.hs view
@@ -33,6 +33,7 @@ , text , file , builder+ , redirect -- *** Setting a header , setHeader , setRawHeader@@ -61,8 +62,8 @@ -- ** Running Wheb , runWhebServer , runWhebServerT- , debugHandler- , debugHandlerT+ , runRawHandler+ , runRawHandlerT -- * Initialize -- ** Routes@@ -75,6 +76,10 @@ , addRoute , addRoutes , catchAll+ -- ** Sockets + , addWhebSocket+ -- ** Sites+ , addSite -- ** Middlewares , addWAIMiddleware , addWhebMiddleware@@ -107,9 +112,9 @@ ) where -import Web.Wheb.WhebT-import Web.Wheb.InitM-import Web.Wheb.Types-import Web.Wheb.Routes-import Web.Wheb.Utils-import Control.Monad.IO.Class+import Control.Monad.IO.Class (MonadIO(..))+import Web.Wheb.InitM (addCleanupHook, addDELETE, addGET, addPOST, addPUT, addRoute, addRoutes, addWhebSocket, addSetting, addSetting', addSettings, addSite, addWAIMiddleware, addWhebMiddleware, catchAll, generateOptions, genMinOpts, readSettingsFile)+import Web.Wheb.Routes ((</>), compilePat, grabInt, grabText, pS, pT, rootPat)+import Web.Wheb.Types (ChunkType(..), CSettings, WhebSocket, EResponse, HandlerData(..), HandlerResponse(..), InitM(..), InitOptions(..), InternalState(..), MethodMatch, MinHandler, MinOpts, MinWheb, PackedSite(..), ParsedChunk(..), Route(..), RouteParamList, SettingsValue(..), UrlBuildError(..), UrlParser(..), UrlPat(..), WhebContent(..), WhebError(..), WhebFile(..), WhebHandler, WhebHandlerT, WhebMiddleware, WhebOptions(..), WhebT(..))+import Web.Wheb.Utils (spack)+import Web.Wheb.WhebT (builder, runRawHandler, runRawHandlerT, file, redirect, getApp, getHandlerState, getPOSTParam, getPOSTParams, getQueryParams, getRawPOST, getRequest, getRequestHeader, getRoute, getRoute', getRouteParam, getRouteParams, getSetting, getSetting', getSetting'', getSettings, getWithApp, getWithRequest, html, modifyHandlerState, modifyHandlerState', putHandlerState, runWhebServer, runWhebServerT, setHeader, setRawHeader, text)
src/Web/Wheb/Cookie.hs view
@@ -8,20 +8,17 @@ , removeCookie ) where -import qualified Data.ByteString as BS-import qualified Blaze.ByteString.Builder as B-import Data.Maybe (fromMaybe)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T-import Data.Time.Calendar-import Data.Time.Clock-import Web.Cookie--import Web.Wheb.Types-import Web.Wheb.Internal-import Web.Wheb.WhebT-import Web.Wheb.Utils+import qualified Blaze.ByteString.Builder as B (toByteString)+import Data.Maybe (fromMaybe)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T (empty, fromStrict, toStrict)+import Data.Time.Calendar (Day(ModifiedJulianDay))+import Data.Time.Clock (secondsToDiffTime, UTCTime(UTCTime))+import Web.Cookie (CookiesText, def, parseCookiesText, renderSetCookie, + SetCookie(setCookieExpires, setCookieName, setCookieValue))+import Web.Wheb.Types (WhebT)+import Web.Wheb.Utils (lazyTextToSBS)+import Web.Wheb.WhebT (getRequestHeader, setRawHeader) getDefaultCookie :: Monad m => WhebT g s m SetCookie getDefaultCookie = return def -- Populate with settings...
src/Web/Wheb/InitM.hs view
@@ -8,10 +8,14 @@ , addPOST , addPUT , addDELETE+ -- ** Sites+ , addSite -- ** Add raw routes , addRoute , addRoutes , catchAll+ -- ** Sockets+ , addWhebSocket -- * Middlewares , addWAIMiddleware , addWhebMiddleware@@ -27,25 +31,23 @@ , 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+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Writer (liftM, MonadWriter(tell), Monoid(mempty), WriterT(runWriterT))+import qualified Data.Map as M (empty, fromList)+import qualified Data.Text.Lazy as T (lines, pack, splitOn, strip, Text, unpack)+import qualified Data.Text.Lazy.IO as T (readFile)+import Data.Typeable (Typeable)+import Network.HTTP.Types.Method (StdMethod(DELETE, GET, POST, PUT))+import Network.Wai (Middleware)+import Network.Wai.Handler.Warp (defaultSettings, setOnClose, setOnOpen)+import Text.Read (readMaybe)+import Web.Routes (Site(..))+import Web.Wheb.Routes (patRoute, compilePat)+import Web.Wheb.Types (CSettings, InitM(..), InitOptions(..), + InternalState(InternalState), MinOpts, PackedSite(PackedSite), Route(Route), SettingsValue(MkVal), UrlParser(UrlParser), + UrlPat, WhebHandlerT, WhebMiddleware, WhebOptions(..), SocketRoute(SocketRoute), WhebSocket)+import Web.Wheb.Utils (defaultErr) addGET :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m () addGET n p h = addRoute $ patRoute (Just n) GET p h@@ -65,6 +67,12 @@ addRoutes :: [Route g s m] -> InitM g s m () addRoutes rs = InitM $ tell $ mempty { initRoutes = rs } +addSite :: T.Text -> Site url (WhebHandlerT g s m) -> InitM g s m ()+addSite t s = InitM $ tell $ mempty { initSites = [PackedSite t s] }++addWhebSocket :: UrlPat -> WhebSocket g s m -> InitM g s m ()+addWhebSocket p h = InitM $ tell $ mempty { initWhebSockets = [SocketRoute (compilePat p) h] }+ -- | Catch all requests regardless of method or path catchAll :: WhebHandlerT g s m -> InitM g s m () catchAll h = addRoute $ Route Nothing (const True) parser h@@ -118,23 +126,24 @@ ((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)}+ let set1 = setOnOpen (\_ -> atomically (addToTVar ac) >> return True) defaultSettings + warpsettings = setOnClose (\_ -> atomically (subFromTVar ac)) set1 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 }+ , appWhebSockets = initWhebSockets+ , appSites = initSites + , 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))) -- | Generate options for an application without a context or state genMinOpts :: InitM () () IO () -> IO MinOpts-genMinOpts m = generateOptions (m >> (return ((), ()))) +genMinOpts m = generateOptions (m >> (return ((), ())))
src/Web/Wheb/Internal.hs view
@@ -1,43 +1,66 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, RankNTypes #-} module Web.Wheb.Internal where -import Control.Monad.Error-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Writer-import qualified Data.Map as M-import qualified Data.Text.Lazy as T--import Network.HTTP.Types.Method-import Network.Wai-import Network.Wai.Parse--import Web.Wheb.Routes-import Web.Wheb.Types-import Web.Wheb.Utils+import qualified Data.ByteString.Char8 as B+import Control.Monad (void)+import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad.Reader (ReaderT(runReaderT))+import Control.Monad.State (evalStateT, StateT(runStateT))+import qualified Data.Map as M (toList)+import qualified Data.Text.Lazy as T (fromStrict, Text, toStrict, pack)+import Network.HTTP.Types.Method (parseMethod, StdMethod(GET))+import Network.Wai (Application, Request(pathInfo, requestMethod), Response)+import Network.Wai.Parse (lbsBackEnd, parseRequestBody)+import Network.Wai.Handler.WebSockets (websocketsOr)+import qualified Network.WebSockets as W+import Web.Wheb.Routes (findUrlMatch, findSiteMatch, findSocketMatch)+import Web.Wheb.Types (EResponse, HandlerData(HandlerData, postData, routeParams),+ HandlerResponse(HandlerResponse), InternalState(..), + WhebContent(toResponse), WhebError(Error404), WhebHandlerT, + WhebMiddleware, WhebOptions(..), WhebT(runWhebT))+import Web.Wheb.Utils (uhOh) -- * Converting to WAI application -- | Convert 'WhebOptions' to 'Application' optsToApplication :: WhebOptions g s m ->- (m EResponse -> IO EResponse) ->+ (forall a. m a -> IO a) -> Application-optsToApplication opts@(WhebOptions {..}) runIO r = do- pData <- liftIO (parseRequestBody lbsBackEnd r)- res <- runIO $ do- let mwData = baseData { postData = pData }- (mRes, st) <- runMiddlewares opts whebMiddlewares mwData- case mRes of- Just resp -> return $ Right resp- Nothing -> case (findUrlMatch stdMthd pathChunks appRoutes) of- Just (h, params) -> do- let hData = mwData { routeParams = params }- runWhebHandler opts h st hData - Nothing -> return $ Left Error404- either handleError return res- where baseData = HandlerData startingCtx r ([], []) [] opts+optsToApplication opts@(WhebOptions {..}) runIO r respond = do+ if ((length appWhebSockets) > 0)+ then websocketsOr W.defaultConnectionOptions socketHandler handleMain r respond+ else handleMain r respond++ where socketHandler pc = do+ case (findSocketMatch pathChunks appWhebSockets) of+ Just (h, params) -> do+ c <- W.acceptRequest pc+ void $ runIO $ do+ (mRes, st) <- runMiddlewares opts whebMiddlewares baseData+ runDebugHandler (opts {startingState = st}) (h c) (baseData { routeParams = params })+ Nothing -> W.rejectRequest pc (B.pack "No socket for path.")++ handleMain r respond = do+ pData <- parseRequestBody lbsBackEnd r+ res <- runIO $ do+ let mwData = baseData { postData = pData }+ (mRes, st) <- runMiddlewares opts whebMiddlewares mwData+ case mRes of+ Just resp -> return $ Right resp+ Nothing -> do+ case (findSiteMatch appSites pathChunks) of+ Just h -> do+ runWhebHandler opts h st mwData+ Nothing -> do+ case (findUrlMatch stdMthd pathChunks appRoutes) of+ Just (h, params) -> do+ let hData = mwData { routeParams = params }+ runWhebHandler opts h st hData + Nothing -> return $ Left Error404+ finished <- either handleError return res+ respond finished+ baseData = HandlerData startingCtx r ([], []) [] opts pathChunks = fmap T.fromStrict $ pathInfo r stdMthd = either (\_-> GET) id $ parseMethod $ requestMethod r runErrorHandler eh = runWhebHandler opts eh startingState baseData@@ -54,10 +77,10 @@ InternalState s -> HandlerData g s m -> m EResponse-runWhebHandler opts@(WhebOptions {..}) handler st hd = do+runWhebHandler (WhebOptions {..}) handler st hd = do (resp, InternalState {..}) <- flip runStateT st $ do flip runReaderT hd $- runErrorT $+ runExceptT $ runWhebT handler return $ fmap (convertResponse respHeaders) resp where convertResponse hds (HandlerResponse status resp) =@@ -72,10 +95,9 @@ runDebugHandler opts@(WhebOptions {..}) handler hd = do flip evalStateT startingState $ do flip runReaderT hd $- runErrorT $+ runExceptT $ runWhebT handler- where convertResponse hds (HandlerResponse status resp) =- toResponse status (M.toList hds) resp+ -- * Running Middlewares -- | Runs middlewares in order, stopping if one returns a response@@ -89,7 +111,7 @@ loop (mw:mws) st = do mwResult <- (runWhebMiddleware opts st hd mw) case mwResult of- (Just resp, nst) -> return mwResult+ (Just _, _) -> return mwResult (Nothing, nst) -> loop mws nst runWhebMiddleware :: Monad m =>@@ -98,10 +120,10 @@ HandlerData g s m -> WhebMiddleware g s m -> m (Maybe Response, InternalState s)-runWhebMiddleware opts@(WhebOptions {..}) st hd mW = do+runWhebMiddleware (WhebOptions {..}) st hd mW = do (eresp, is@InternalState {..}) <- flip runStateT st $ do flip runReaderT hd $- runErrorT $+ runExceptT $ runWhebT mW return $ (convertResponse respHeaders eresp, is) where convertResponse hds (Right (Just (HandlerResponse status resp))) =
src/Web/Wheb/Plugins/Auth.hs view
@@ -33,20 +33,13 @@ , getUserSessionKey ) where -import Control.Applicative ((<*>))-import Control.Monad (void, liftM)-import Control.Monad.Error-import Control.Monad.IO.Class-import Crypto.PasswordStore-import Data.Maybe-import Data.Text.Lazy (Text)-import Data.Text.Lazy as T-import Data.Text.Lazy.Encoding as T-import Data.Text.Encoding as ES--import Web.Wheb-import Web.Wheb.Types-import Web.Wheb.Plugins.Session+import Control.Monad.Except (liftM, MonadError(throwError), MonadIO(..))+import Crypto.PasswordStore (makePassword, verifyPassword)+import Data.Text.Encoding as ES (decodeUtf8, encodeUtf8)+import Data.Text.Lazy as T (fromStrict, pack, Text, toStrict)+import Web.Wheb (getHandlerState, getWithApp, modifyHandlerState', + WhebError(Error403), WhebHandlerT, WhebMiddleware, WhebT)+import Web.Wheb.Plugins.Session (deleteSessionValue, getSessionValue', SessionApp, setSessionValue) -- * Auth functions
src/Web/Wheb/Plugins/Debug/MemoryBackend.hs view
@@ -1,16 +1,15 @@ module Web.Wheb.Plugins.Debug.MemoryBackend where +import Control.Concurrent.STM (atomically, modifyTVar, newTVarIO, readTVarIO, TVar, writeTVar) import Control.Monad (liftM)-import Control.Monad.IO.Class-import Control.Concurrent.STM+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Map as M (alter, delete, empty, insert, lookup, Map, member, update)+import Data.Maybe (fromMaybe) import Data.Text.Lazy (Text)-import Data.Map as M-import Data.Maybe (fromMaybe, fromJust)--import Web.Wheb-import Web.Wheb.Types-import Web.Wheb.Plugins.Auth-import Web.Wheb.Plugins.Session+import Web.Wheb (InitM)+import Web.Wheb.Plugins.Auth (AuthBackend(..), AuthContainer(..), AuthError(..), AuthUser(AuthUser), + getUserSessionKey, makePwHash, PwHash, UserKey, verifyPw)+import Web.Wheb.Plugins.Session (deleteSessionValue, SessionBackend(..), SessionContainer(..)) data SessionData = SessionData { sessionMemory :: TVar (M.Map Text (M.Map Text Text)) }
src/Web/Wheb/Plugins/Session.hs view
@@ -16,22 +16,20 @@ , clearSessionKey ) where -import Control.Monad.IO.Class import Control.Monad (liftM)-import Data.Maybe-import Data.Text.Lazy (Text, pack)-import Data.Text.Lazy.Encoding as T-import Data.UUID-import Data.UUID.V4--import Web.Wheb-import Web.Wheb.Cookie-import Web.Wheb.Types+import Control.Monad.IO.Class (MonadIO(..))+import Data.Maybe (fromMaybe)+import Data.Text.Lazy (pack, Text)+import Data.Text.Lazy.Encoding as T (decodeUtf8)+import Data.UUID (toLazyASCIIBytes)+import Data.UUID.V4 (nextRandom)+import Web.Wheb (getWithApp, WhebT)+import Web.Wheb.Cookie (getCookie, setCookie) -- | Initial pass on abstract plugin for Sessions. -- Possibly add support for Typable to ease typecasting. -+session_cookie_key :: Text session_cookie_key = pack "-session-" data SessionContainer = forall r. SessionBackend r => SessionContainer r
src/Web/Wheb/Routes.hs view
@@ -17,23 +17,24 @@ , matchUrl , generateUrl , findUrlMatch-+ , findSocketMatch+ , findSiteMatch -- * Utilities , testUrlParser ) where -import qualified Data.Text.Lazy as T-import Data.Text.Lazy.Read-import Data.Maybe (isJust)-import Data.Typeable-import Network.HTTP.Types.Method-import Network.HTTP.Types.URI--import Data.Maybe (fromJust)-import Data.Monoid ((<>))--import Web.Wheb.Types-import Web.Wheb.Utils+import Data.Monoid ((<>))+import qualified Data.Text.Lazy as T (fromStrict, null, pack, Text, toStrict)+import Data.Text.Lazy.Read (decimal, Reader)+import Data.Typeable (cast, Typeable)+import Network.HTTP.Types.Method (StdMethod)+import Network.HTTP.Types.URI (decodePathSegments, encodePathSegments)+import Web.Routes (runSite)+import Web.Wheb.Types (ChunkType(..), ParsedChunk(..), Route(Route), RouteParamList, + UrlBuildError(NoParam, ParamTypeMismatch), UrlParser(UrlParser),+ UrlPat(Chunk, Composed, FuncChunk), WhebHandlerT, SocketRoute(SocketRoute), + PackedSite(..), WhebSocket)+import Web.Wheb.Utils (builderToText, lazyTextToSBS, spack) -- | Build a 'Route' from a 'UrlPat' patRoute :: (Maybe T.Text) -> @@ -105,6 +106,22 @@ | otherwise = case f path of Just params -> Just (h, params) Nothing -> findUrlMatch rmtd path rs++-- | Sort through socket routes to find a match+findSocketMatch :: [T.Text] -> [SocketRoute g s m] -> Maybe (WhebSocket g s m, RouteParamList)+findSocketMatch _ [] = Nothing+findSocketMatch path ((SocketRoute (UrlParser f _) h):rs) = + case f path of+ Just params -> Just (h, params)+ Nothing -> findSocketMatch path rs++findSiteMatch :: [PackedSite g s m] -> + [T.Text] -> + Maybe (WhebHandlerT g s m)+findSiteMatch [] _ = Nothing+findSiteMatch ((PackedSite t site):sites) cs = + either (const (findSiteMatch sites cs)) Just $+ runSite (T.toStrict t) site (map T.toStrict cs) -- | Test a parser to make sure it can match what it produces and vice versa testUrlParser :: UrlParser -> RouteParamList -> Bool
src/Web/Wheb/Types.hs view
@@ -5,32 +5,27 @@ module Web.Wheb.Types where -import Blaze.ByteString.Builder (Builder, fromLazyByteString)-import Control.Concurrent.STM-import Control.Applicative-import Control.Monad.Error-import Control.Monad.Trans-import Control.Monad.IO.Class-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer-import Data.Monoid ((<>))--import qualified Data.ByteString.Lazy as LBS-import Data.List (intercalate)-import Data.Map as M-import Data.String (IsString(..))-import qualified Data.Text.Lazy as T-import Data.Typeable--import Network.Wai (Request, Response, Middleware, responseBuilder)-import Network.Wai.Handler.Warp as Warp-import Network.Wai.Parse-import Network.HTTP.Types.Method-import Network.HTTP.Types.Status-import Network.HTTP.Types.Header--import Data.ByteString (ByteString)+import Control.Applicative (Applicative)+import Control.Concurrent.STM (TVar)+import Control.Monad.Except (ExceptT(ExceptT), MonadError(..), MonadIO, MonadTrans(..))+import Control.Monad.Reader (ReaderT(ReaderT))+import Control.Monad.State (StateT)+import Control.Monad.Writer ((<>), Monoid(mappend, mempty), WriterT(WriterT))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS (ByteString)+import Data.List (intercalate)+import Data.Map as M (Map)+import Data.String (IsString(..))+import qualified Data.Text.Lazy as T (pack, Text, unpack)+import Data.Typeable (Typeable)+import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)+import Network.HTTP.Types.Method (StdMethod)+import Network.HTTP.Types.Status (Status)+import Network.Wai (Middleware, Request, Response)+import Network.Wai.Handler.Warp as Warp (Settings)+import Network.Wai.Parse (File, Param)+import Network.WebSockets (Connection)+import Web.Routes (Site(..)) -- | WhebT g s m@@ -41,7 +36,7 @@ -- -- * m -> Monad we are transforming newtype WhebT g s m a = WhebT - { runWhebT :: ErrorT WhebError + { runWhebT :: ExceptT WhebError (ReaderT (HandlerData g s m) (StateT (InternalState s) m)) a } deriving ( Functor, Applicative, Monad, MonadIO ) @@ -87,25 +82,32 @@ | URLError T.Text UrlBuildError deriving (Show) -instance Error WhebError where - strMsg = Error500- -- | Monoid to use in InitM's WriterT data InitOptions g s m = InitOptions { initRoutes :: [ Route g s m ]+ , initWhebSockets :: [ SocketRoute g s m ]+ , initSites :: [ PackedSite g s m ] , initSettings :: CSettings , initWaiMw :: Middleware , initWhebMw :: [ WhebMiddleware g s m ] , initCleanup :: [ IO () ] } instance Monoid (InitOptions g s m) where- mappend (InitOptions a1 b1 c1 d1 e1) (InitOptions a2 b2 c2 d2 e2) = - InitOptions (a1 <> a2) (b1 <> b2) (c2 . c1) (d1 <> d2) (e1 <> e2)- mempty = InitOptions mempty mempty id mempty mempty+ mappend (InitOptions a1 ws1 s1 b1 c1 d1 e1) (InitOptions a2 ws2 s2 b2 c2 d2 e2) = + InitOptions (a1 <> a2)+ (ws1 <> ws2)+ (s1 <> s2)+ (b1 <> b2)+ (c2 . c1) + (d1 <> d2) + (e1 <> e2)+ mempty = InitOptions mempty mempty mempty mempty id mempty mempty -- | The main option datatype for Wheb data WhebOptions g s m = MonadIO m => WhebOptions { appRoutes :: [ Route g s m ]+ , appWhebSockets :: [ SocketRoute g s m ]+ , appSites :: [ PackedSite g s m ] , runTimeSettings :: CSettings , warpSettings :: Warp.Settings , startingCtx :: g -- ^ Global ctx shared between requests@@ -113,7 +115,7 @@ , waiStack :: Middleware , whebMiddlewares :: [ WhebMiddleware g s m ] , defaultErrorHandler :: WhebError -> WhebHandlerT g s m- , shutdownTVar :: TVar Bool+ , shutdownTVar :: TVar Bool , activeConnections :: TVar Int , cleanupActions :: [ IO () ] } @@ -124,6 +126,7 @@ type WhebHandler g s = WhebT g s IO HandlerResponse type WhebHandlerT g s m = WhebT g s m HandlerResponse type WhebMiddleware g s m = WhebT g s m (Maybe HandlerResponse)+type WhebSocket g s m = Connection -> WhebT g s m () -- | A minimal type for WhebT type MinWheb a = WhebT () () IO a@@ -132,6 +135,7 @@ type MinOpts = WhebOptions () () IO -- * Routes+data PackedSite g s m = forall a . PackedSite T.Text (Site a (WhebHandlerT g s m)) type RouteParamList = [(T.Text, ParsedChunk)] type MethodMatch = StdMethod -> Bool@@ -154,6 +158,11 @@ , routeMethod :: MethodMatch , routeParser :: UrlParser , routeHandler :: (WhebHandlerT g s m) }++data SocketRoute g s m = SocketRoute+ { srouteParser :: UrlParser+ , srouteHandler :: WhebSocket g s m+ } data ChunkType = IntChunk | TextChunk deriving (Show)
src/Web/Wheb/Utils.hs view
@@ -2,20 +2,15 @@ module Web.Wheb.Utils where -import Blaze.ByteString.Builder (Builder- ,fromLazyByteString- ,toLazyByteString)-import Control.Monad-import Data.Monoid-import Data.Conduit as C-import Data.Conduit.List (fold)-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T-import qualified Data.Text.Encoding as TS-import Network.HTTP.Types.Status-import Network.Wai--import Web.Wheb.Types+import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString)+import Data.IORef (atomicModifyIORef, newIORef, readIORef)+import Data.Monoid ((<>), Monoid(mappend, mempty))+import qualified Data.Text.Encoding as TS (decodeUtf8, encodeUtf8)+import qualified Data.Text.Lazy as T (fromStrict, pack, Text, toStrict)+import qualified Data.Text.Lazy.Encoding as T (decodeUtf8, encodeUtf8)+import Network.HTTP.Types.Status (status500)+import Network.Wai (Response, responseBuilder, responseFile, responseLBS, responseToStream)+import Web.Wheb.Types (HandlerResponse(..), WhebContent(..), WhebError, WhebFile(..), WhebHandlerT) lazyTextToSBS = TS.encodeUtf8 . T.toStrict sbsToLazyText = T.fromStrict . TS.decodeUtf8@@ -27,12 +22,17 @@ -- | See a 'HandlerResponse's as 'Text' showResponseBody :: HandlerResponse -> IO T.Text-showResponseBody (HandlerResponse s r) = - liftM (T.decodeUtf8 . toLazyByteString) builderBody- where chunkFlatAppend m (C.Chunk more) = m `mappend` more- chunkFlatAppend m _ = m- builderBody = body' (C.$$ fold chunkFlatAppend mempty)- (_, _, body') = responseToSource $ toResponse s [] r+showResponseBody (HandlerResponse s r) = do+ let (_, _, f) = responseToStream $ toResponse s [] r+ f $ \streamingBody -> do+ builderRef <- newIORef mempty+ let add :: Builder -> IO ()+ add b = atomicModifyIORef builderRef $ \builder ->+ (builder `mappend` b, ())+ flush :: IO ()+ flush = return ()+ streamingBody add flush+ fmap (T.decodeUtf8 . toLazyByteString) $ readIORef builderRef ----------------------- Instances ------------------------ instance WhebContent Builder where
src/Web/Wheb/WhebT.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, RankNTypes #-} module Web.Wheb.WhebT (@@ -19,6 +19,7 @@ , text , file , builder+ , redirect -- * Settings , getSetting@@ -45,40 +46,38 @@ -- * Running Wheb , runWhebServer , runWhebServerT- , debugHandler- , debugHandlerT+ , runRawHandler+ , runRawHandlerT ) where -import Blaze.ByteString.Builder (Builder)-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception as E-import Control.Monad.Error-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.State--import qualified Data.ByteString.Lazy as LBS-import Data.CaseInsensitive (mk)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import qualified Data.Text.Lazy as T-import Data.Typeable (Typeable, cast)-import Data.List (find)--import Network.HTTP.Types.Header-import Network.HTTP.Types.Status-import Network.HTTP.Types.URI-import Network.Wai-import Network.Wai.Handler.Warp as W-import Network.Wai.Parse--import System.Posix.Signals (installHandler, Handler(Catch), sigINT, sigTERM)--import Web.Wheb.Internal-import Web.Wheb.Routes-import Web.Wheb.Types-import Web.Wheb.Utils+import Blaze.ByteString.Builder (Builder)+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM (atomically, readTVar, newTVarIO, writeTVar)+import Control.Monad.Error (liftM, MonadError(throwError), MonadIO, void)+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.Lazy as T (pack, empty, Text)+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, sigTSTP, sigTERM)+import Web.Wheb.Internal (optsToApplication, runDebugHandler)+import Web.Wheb.Routes (generateUrl, getParam)+import Web.Wheb.Types (CSettings, EResponse, HandlerData(HandlerData, globalCtx, globalSettings, postData, request, routeParams), + HandlerResponse(HandlerResponse), InternalState(InternalState, reqState, respHeaders), + Route(..), RouteParamList, SettingsValue(..), + UrlBuildError(UrlNameNotFound), WhebError(RouteParamDoesNotExist, URLError), + WhebFile(WhebFile), WhebHandlerT, WhebOptions(..), WhebT(WhebT))+import Web.Wheb.Utils (lazyTextToSBS, sbsToLazyText) -- * ReaderT and StateT Functionality @@ -150,11 +149,11 @@ -- | Convert 'Either' from 'getRoute'' into an error in the Monad getRoute :: Monad m => T.Text -> RouteParamList -> WhebT g s m T.Text-getRoute t l = do- res <- getRoute' t l+getRoute name l = do+ res <- getRoute' name l case res of Right t -> return t- Left err -> throwError $ URLError t err+ Left err -> throwError $ URLError name err -- | Generate a route from a name and param list. getRoute' :: Monad m => T.Text -> @@ -168,7 +167,7 @@ getRawRoute :: Monad m => T.Text -> RouteParamList -> WhebT g s m (Maybe (Route g s m))-getRawRoute n l = WhebT $ liftM f ask +getRawRoute n _ = WhebT $ liftM f ask where findRoute (Route {..}) = fromMaybe False (fmap (==n) routeName) f = ((find findRoute) . appRoutes . globalSettings) @@ -239,43 +238,53 @@ builder c b = do setHeader (T.pack "Content-Type") c return $ HandlerResponse status200 b++-- | Redirect to a given URL+redirect :: Monad m => T.Text -> WhebHandlerT g s m+redirect c = do+ setHeader (T.pack "Location") c+ return $ HandlerResponse status302 T.empty -- * Running a Wheb Application -- | Running a Handler with a custom Transformer-debugHandlerT :: WhebOptions g s m ->+runRawHandlerT :: WhebOptions g s m -> (m (Either WhebError a) -> IO (Either WhebError a)) -> Request -> WhebT g s m a -> IO (Either WhebError a)-debugHandlerT opts@(WhebOptions {..}) runIO r h = +runRawHandlerT opts@(WhebOptions {..}) runIO r h = runIO $ runDebugHandler opts h baseData where baseData = HandlerData startingCtx r ([], []) [] opts --- | Convenience wrapper for 'debugHandlerT' function in 'IO'-debugHandler :: WhebOptions g s IO -> +-- | Convenience wrapper for 'runRawHandlerT' function in 'IO'+runRawHandler :: WhebOptions g s IO -> WhebT g s IO a -> IO (Either WhebError a)-debugHandler opts h = debugHandlerT opts id defaultRequest h+runRawHandler opts h = runRawHandlerT opts id defaultRequest h -- | Run a server with a function to run your inner Transformer to IO and -- generated options-runWhebServerT :: (m EResponse -> IO EResponse) ->+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+ installHandler sigTSTP (Catch (atomically $ writeTVar forceTVar True >> writeTVar shutdownTVar True)) Nothing forkIO $ runSettings rtSettings $ gracefulExit $- waiStack $ + waiStack $ optsToApplication opts runIO loop- waitForConnections+ putStrLn $ "Waiting for connections to close..."+ waitForConnections forceTVar putStrLn $ "Shutting down server..." sequence_ cleanupActions @@ -283,19 +292,20 @@ loop = do shutDown <- atomically $ readTVar shutdownTVar if shutDown then return () else (threadDelay 100000) >> loop- gracefulExit app r = do+ gracefulExit app r respond = do isExit <- atomically $ readTVar shutdownTVar case isExit of- False -> app r- True -> return $ responseLBS serviceUnavailable503 [] LBS.empty- waitForConnections = do+ False -> app r respond+ True -> respond $ responseLBS serviceUnavailable503 [] LBS.empty+ waitForConnections forceTVar = do openConnections <- atomically $ readTVar activeConnections- if (openConnections > 0)- then waitForConnections- else return ()+ force <- atomically $ readTVar forceTVar+ if (openConnections == 0 || force)+ then return ()+ else waitForConnections forceTVar port = fromMaybe 3000 $ (M.lookup (T.pack "port") runTimeSettings) >>= (\(MkVal m) -> cast m)- rtSettings = warpSettings { W.settingsPort = port }+ rtSettings = W.setPort port warpSettings -- | Convenience wrapper for 'runWhebServerT' function in IO runWhebServer :: (WhebOptions g s IO) -> IO ()