Wheb 0.0.1.0 → 0.0.1.1
raw patch · 12 files changed
+598/−261 lines, 12 files
Files
- Web/Wheb.hs +103/−7
- Web/Wheb/Cookie.hs +14/−13
- Web/Wheb/InitM.hs +36/−17
- Web/Wheb/Internal.hs +41/−34
- Web/Wheb/Plugins/Auth.hs +76/−44
- Web/Wheb/Plugins/Debug/MemoryBackend.hs +1/−0
- Web/Wheb/Plugins/Session.hs +4/−4
- Web/Wheb/Routes.hs +81/−36
- Web/Wheb/Types.hs +69/−43
- Web/Wheb/Utils.hs +4/−1
- Web/Wheb/WhebT.hs +103/−19
- Wheb.cabal +66/−43
Web/Wheb.hs view
@@ -1,8 +1,104 @@-module Web.Wheb (module All) where+{-| -import Web.Wheb.Internal as All-import Web.Wheb.Utils as All-import Web.Wheb.WhebT as All-import Web.Wheb.InitM as All-import Web.Wheb.Types as All-import Web.Wheb.Routes as All+This module reexports Wheb modules. It should be the only thing you need to+import to get started.++@+import Web.Wheb+import Data.Text.Lazy (pack)++main :: IO ()+main = do+ opts <- generateOptions $ addGET (pack \".\") rootPat $ (text (pack \"Hi!\"))+ runWhebServer (opts :: MinOpts)+@++-}+module Web.Wheb + (+ -- * Handlers+ -- ** ReaderT and StateT Functionality+ -- *** ReaderT+ getApp+ , getWithApp+ -- *** StateT+ , getReqState+ , putReqState+ , modifyReqState+ , modifyReqState'+ + -- ** Dealing with responses+ -- *** Creating a 'HandlerResponse'+ , html+ , text+ , file+ -- *** Setting a header+ , setHeader+ , setRawHeader+ + -- * Settings+ , getSetting+ , getSetting'+ , getSettings+ + -- * Routes+ , getRouteParams+ , getRouteParam+ , getRoute+ , getRoute'+ + -- * Request reading+ , getRequest+ , getRequestHeader+ , getWithRequest+ , getQueryParams+ , getPOSTParam+ , getPOSTParams+ , getRawPOST+ + -- ** Running Wheb+ , runWhebServer+ , runWhebServerT+ , debugHandler+ , debugHandlerT+ + -- * Initialize+ -- ** Routes+ -- *** Named routes convenience functions+ , addGET+ , addPOST+ -- *** Add raw routes+ , addRoute+ , addRoutes+ -- ** Middlewares+ , addWAIMiddleware+ , addWhebMiddleware+ -- ** Settings+ , addSetting+ , addSetting'+ , addSettings+ + -- * Running+ , generateOptions+ + -- * Routes+ -- ** URL Patterns+ , compilePat+ , rootPat+ + -- ** URL building+ , (</>)+ , grabInt+ , grabText+ , pT+ , pS+ -- * Types+ , module Web.Wheb.Types+ , Default (..)+ ) where++import Web.Wheb.WhebT+import Web.Wheb.InitM+import Web.Wheb.Types+import Web.Wheb.Routes+import Data.Default
Web/Wheb/Cookie.hs view
@@ -7,21 +7,21 @@ , getCookies , removeCookie ) where--import Data.Maybe (fromMaybe)-import Data.Text.Lazy (Text)-import Data.Time.Calendar-import Data.Time.Clock-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T+ import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL import qualified Blaze.ByteString.Builder as B--import Web.Cookie+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-import Web.Wheb.Types+import Web.Wheb.Types+import Web.Wheb.Internal+import Web.Wheb.WhebT+import Web.Wheb.Utils getDefaultCookie :: Monad m => WhebT g s m SetCookie getDefaultCookie = return def -- Populate with settings...@@ -37,7 +37,8 @@ cookieText = B.toByteString $ renderSetCookie cookie getCookies :: Monad m => WhebT g s m CookiesText-getCookies = (getHeader "Cookie") >>= (return . parseFunc . (fromMaybe T.empty))+getCookies = (getRequestHeader "Cookie") >>= + (return . parseFunc . (fromMaybe T.empty)) where parseFunc = parseCookiesText . lazyTextToSBS getCookie :: Monad m => Text -> WhebT g s m (Maybe Text)
Web/Wheb/InitM.hs view
@@ -1,6 +1,26 @@ {-# LANGUAGE RecordWildCards #-} -module Web.Wheb.InitM where+module Web.Wheb.InitM+ (+ -- * Routes+ -- ** Named routes convenience functions+ addGET+ , addPOST+ -- ** Add raw routes+ , addRoute+ , addRoutes+ -- * Middlewares+ , addWAIMiddleware+ , addWhebMiddleware+ -- * Settings+ , addSetting+ , addSetting'+ , addSettings+ + -- * Running+ , generateOptions+ + ) where import Control.Monad.IO.Class import Control.Monad.Writer@@ -16,45 +36,44 @@ import Web.Wheb.Types import Web.Wheb.Utils -rGET :: (Maybe T.Text) -> UrlPat -> WhebHandlerT g s m -> Route g s m-rGET n p = Route n (==GET) (compilePat p)--rPOST :: (Maybe T.Text) -> UrlPat -> WhebHandlerT g s m -> Route g s m-rPOST n p = Route n (==POST) (compilePat p)- addGET :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m () addGET n p h = addRoute $ rGET (Just n) p h addPOST :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m () addPOST n p h = addRoute $ rPOST (Just n) p h -addWAIMiddleware :: Middleware -> InitM g s m ()-addWAIMiddleware m = InitM $ tell $ mempty { initWaiMw = m }+addRoute :: Route g s m -> InitM g s m ()+addRoute r = addRoutes [r] -addWhebMiddleware :: WhebMiddleware g s m -> InitM g s m ()-addWhebMiddleware m = InitM $ tell $ mempty { initWhebMw = [m] }+addRoutes :: [Route g s m] -> InitM g s m ()+addRoutes rs = InitM $ tell $ mempty { initRoutes = rs } +-- | Catch all routes regardless of method or path catchAllRoutes :: WhebHandlerT g s m -> InitM g s m () catchAllRoutes h = addRoute $ Route Nothing (const True) parser h where parser = UrlParser (const (Just [])) (const (Right $ T.pack "/*")) -addRoute :: Route g s m -> InitM g s m ()-addRoute r = addRoutes [r]+-- | Add generic "WAI" middleware+addWAIMiddleware :: Middleware -> InitM g s m ()+addWAIMiddleware m = InitM $ tell $ mempty { initWaiMw = m } -addRoutes :: [Route g s m] -> InitM g s m ()-addRoutes rs = InitM $ tell $ mempty { initRoutes = rs }+-- | Add "Wheb" specific middleware+addWhebMiddleware :: WhebMiddleware g s m -> InitM g s m ()+addWhebMiddleware m = InitM $ tell $ mempty { initWhebMw = [m] } --- | Help prevent monomorphism errors for simple settings.++-- | Wrapped 'addSetting'' to help prevent monomorphism errors for simple settings. addSetting :: T.Text -> T.Text -> InitM g s m () addSetting = addSetting' +-- | Adds a setting value, replacing it if its key already exists. 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 } -+-- | Generate 'WhebOptions' from 'InitM' in 'IO' generateOptions :: MonadIO m => InitM g s m g -> IO (WhebOptions g s m) generateOptions m = do (g, InitOptions {..}) <- runWriterT (runInitM m)
Web/Wheb/Internal.hs view
@@ -19,20 +19,9 @@ import Web.Wheb.Types import Web.Wheb.Utils -runDebugHandler :: (Default s, Monad m) =>- WhebOptions g s m ->- WhebT g s m a ->- HandlerData g s m ->- m (Either WhebError a)-runDebugHandler opts@(WhebOptions {..}) handler hd = do- flip evalStateT def $ do- flip runReaderT hd $- runErrorT $- runWhebT handler- where convertResponse hds (HandlerResponse status resp) =- toResponse status (M.toList hds) resp- - +-- * Converting to WAI application+ +-- | Convert 'WhebOptions' to 'Application' optsToApplication :: (Default s) => WhebOptions g s m -> (m EResponse -> IO EResponse) -> Application@@ -49,14 +38,48 @@ runWhebHandler opts h st hData Nothing -> return $ Left Error404 either handleError return res- where baseData = HandlerData startingCtx r ([], []) [] opts+ where baseData = HandlerData startingCtx r ([], []) [] opts pathChunks = fmap T.fromStrict $ pathInfo r- stdMthd = either (\_-> GET) id $ parseMethod $ requestMethod r+ stdMthd = either (\_-> GET) id $ parseMethod $ requestMethod r handleError err = do errRes <- runIO $ - runWhebHandler opts (defaultErrorHandler err) def baseData+ runWhebHandler opts (defaultErrorHandler err) def baseData either (return . (const uhOh)) return errRes- ++-- * Running Handlers++-- | Run all inner wheb monads to the top level.+runWhebHandler :: (Default s, Monad m) =>+ WhebOptions g s m ->+ WhebHandlerT g s m ->+ InternalState s ->+ HandlerData g s m ->+ m EResponse+runWhebHandler opts@(WhebOptions {..}) handler st hd = do+ (resp, InternalState {..}) <- flip runStateT st $ do+ flip runReaderT hd $+ runErrorT $+ runWhebT handler+ return $ fmap (convertResponse respHeaders) resp + where convertResponse hds (HandlerResponse status resp) =+ toResponse status (M.toList hds) resp++-- | Same as above but returns arbitrary type for debugging.+runDebugHandler :: (Default s, Monad m) =>+ WhebOptions g s m ->+ WhebT g s m a ->+ HandlerData g s m ->+ m (Either WhebError a)+runDebugHandler opts@(WhebOptions {..}) handler hd = do+ flip evalStateT def $ do+ flip runReaderT hd $+ runErrorT $+ 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 runMiddlewares :: (Default s, Monad m) => WhebOptions g s m -> [WhebMiddleware g s m] ->@@ -85,19 +108,3 @@ where convertResponse hds (Right (Just (HandlerResponse status resp))) = Just (toResponse status (M.toList hds) resp) convertResponse _ _ = Nothing- -runWhebHandler :: (Default s, Monad m) =>- WhebOptions g s m ->- WhebHandlerT g s m ->- InternalState s ->- HandlerData g s m ->- m EResponse-runWhebHandler opts@(WhebOptions {..}) handler st hd = do- (resp, InternalState {..}) <- flip runStateT st $ do- flip runReaderT hd $- runErrorT $- runWhebT handler- return $ fmap (convertResponse respHeaders) resp - where convertResponse hds (HandlerResponse status resp) =- toResponse status (M.toList hds) resp-
Web/Wheb/Plugins/Auth.hs view
@@ -3,30 +3,39 @@ {-# LANGUAGE RankNTypes #-} module Web.Wheb.Plugins.Auth - ( AuthUser (..)+ ( + -- * Main functions+ login+ , logout+ , register+ , getCurrentUser+ , queryCurrentUser+ , loginRequired+ + -- * Middleware+ , authMiddleware + + -- * Types+ , AuthUser (..) , AuthContainer (..) , AuthApp (..) , AuthState (..) , AuthBackend (..) , AuthError (..)- + , UserKey , Password , PwHash - , authMiddleware- , login- , logout- , register- , getCurrentUser- , queryCurrentUser- , loginRequired+ -- * Utils , makePwHash , verifyPw+ , 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@@ -38,8 +47,60 @@ import Web.Wheb import Web.Wheb.Types import Web.Wheb.Plugins.Session+ +-- * Auth functions +-- | Register a user+register :: (AuthApp a, MonadIO m) => UserKey -> Password -> WhebT a b m (Either AuthError AuthUser)+register un pw = runWithContainer $ backendRegister un pw +-- | Log a user in+login :: (AuthApp a, AuthState b, MonadIO m) => UserKey -> Password -> WhebT a b m (Either AuthError AuthUser)+login un pw = do+ loginResult <- (runWithContainer $ backendLogin un pw)+ case loginResult of+ Right au@(AuthUser userKey) -> do+ sessionKey <- getUserSessionKey+ deleteSessionValue sessionKey+ setSessionValue sessionKey userKey+ authSetUser (Just au)+ _ -> return ()+ return loginResult++-- | Log a user out+logout :: (AuthApp a, AuthState b, MonadIO m) => WhebT a b m ()+logout = (runWithContainer backendLogout) >> (authSetUser Nothing)++-- | Get the current user from the request state (Needs to be populated first+-- with 'authMiddleware')+getCurrentUser :: (AuthState b, MonadIO m) => WhebT a b m (Maybe AuthUser)+getCurrentUser = liftM getAuthUser getReqState++-- | Explicitly query a user with the backend. Since this is an IO hit, it is+-- better to use the middleware and 'getCurrentUser'+queryCurrentUser :: (AuthApp a, MonadIO m) => WhebT a b m (Maybe AuthUser)+queryCurrentUser = getUserSessionKey >>= + getSessionValue' (T.pack "") >>=+ (\uid -> runWithContainer $ backendGetUser uid)++-- | Checks if a user is logged in with 'getCurrentUser' and prevents a handler+-- from running if they aren't+loginRequired :: (AuthState b, MonadIO m) =>+ WhebHandlerT a b m ->+ WhebHandlerT a b m+loginRequired action = getCurrentUser >>=+ (maybe (throwError Error403) (const action))++-- * Middleware++-- | Auto-populates the request state with the current user.+authMiddleware :: (AuthApp a, AuthState b, MonadIO m) => WhebMiddleware a b m+authMiddleware = do+ cur <- queryCurrentUser+ authSetUser cur+ return Nothing++ type UserKey = Text type Password = Text type PwHash = Text@@ -48,23 +109,29 @@ deriving (Show) data AuthUser = AuthUser { uniqueUserKey :: UserKey } deriving (Show)+ type PossibleUser = Maybe AuthUser data AuthContainer = forall r. AuthBackend r => AuthContainer r +-- | Interface for creating Auth backends class SessionApp a => AuthApp a where getAuthContainer :: a -> AuthContainer +-- | Minimal implementation for a class AuthState a where getAuthUser :: a -> PossibleUser modifyAuthUser :: (PossibleUser -> PossibleUser) -> a -> a +-- | Interface for creating Auth backends class AuthBackend c where backendLogin :: (AuthApp a, MonadIO m) => SessionApp a => UserKey -> Password -> c -> WhebT a b m (Either AuthError AuthUser) backendRegister :: (AuthApp a, MonadIO m) => UserKey -> Password -> c -> WhebT a b m (Either AuthError AuthUser) backendGetUser :: (AuthApp a, MonadIO m) => UserKey -> c -> WhebT a b m (Maybe AuthUser) backendLogout :: (AuthApp a, MonadIO m) => c -> WhebT a b m () backendLogout _ = getUserSessionKey >>= deleteSessionValue+ +-- * Internal runWithContainer :: (AuthApp a, MonadIO m) => (forall r. AuthBackend r => r -> WhebT a s m b) -> @@ -76,43 +143,8 @@ authSetUser :: (AuthApp a, AuthState b, MonadIO m) => PossibleUser -> WhebT a b m () authSetUser cur = modifyReqState' (modifyAuthUser (const cur)) -authMiddleware :: (AuthApp a, AuthState b, MonadIO m) => WhebMiddleware a b m-authMiddleware = do- cur <- queryCurrentUser- authSetUser cur- return Nothing- getUserSessionKey :: (AuthApp a, MonadIO m) => WhebT a b m Text getUserSessionKey = return $ T.pack "user-id" -- later read from settings.--register :: (AuthApp a, MonadIO m) => UserKey -> Password -> WhebT a b m (Either AuthError AuthUser)-register un pw = runWithContainer $ backendRegister un pw--login :: (AuthApp a, AuthState b, MonadIO m) => UserKey -> Password -> WhebT a b m (Either AuthError AuthUser)-login un pw = do- loginResult <- (runWithContainer $ backendLogin un pw)- case loginResult of- Right au@(AuthUser userKey) -> do- sessionKey <- getUserSessionKey- deleteSessionValue sessionKey- setSessionValue sessionKey userKey- authSetUser (Just au)- _ -> return ()- return loginResult--logout :: (AuthApp a, AuthState b, MonadIO m) => WhebT a b m ()-logout = (runWithContainer backendLogout) >> (authSetUser Nothing)--getCurrentUser :: (AuthState b, MonadIO m) => WhebT a b m (Maybe AuthUser)-getCurrentUser = liftM getAuthUser getReqState--queryCurrentUser :: (AuthApp a, MonadIO m) => WhebT a b m (Maybe AuthUser)-queryCurrentUser = getUserSessionKey >>= - getSessionValue' (T.pack "") >>=- (\uid -> runWithContainer $ backendGetUser uid)--loginRequired :: WhebT a b m () -> WhebT a b m ()-loginRequired action = action makePwHash :: MonadIO m => Password -> WhebT a b m PwHash makePwHash pw = liftM (T.fromStrict . ES.decodeUtf8) $
Web/Wheb/Plugins/Debug/MemoryBackend.hs view
@@ -57,6 +57,7 @@ pwHash <- makePwHash pw liftIO $ atomically $ writeTVar tv (M.insert name pwHash users) return (Right $ AuthUser name)+ backendLogout _ = getUserSessionKey >>= deleteSessionValue initSessionMemory :: InitM g s m SessionContainer initSessionMemory = do
Web/Wheb/Plugins/Session.hs view
@@ -16,9 +16,6 @@ , clearSessionKey ) where --- | Initial pass on abstract plugin for Sessions.--- Possibly add support for Typable to ease typecasting.- import Control.Monad.IO.Class import Control.Monad (liftM) import Data.Maybe@@ -27,10 +24,13 @@ import Data.UUID import Data.UUID.V4 - import Web.Wheb import Web.Wheb.Cookie import Web.Wheb.Types++-- | Initial pass on abstract plugin for Sessions.+-- Possibly add support for Typable to ease typecasting.+ session_cookie_key = pack "-session-"
Web/Wheb/Routes.hs view
@@ -1,5 +1,26 @@-module Web.Wheb.Routes where+module Web.Wheb.Routes+ (+ -- * Convenience constructors+ rGET+ , rPOST+ -- * URL Patterns+ , compilePat+ , rootPat + -- ** URL building+ , (</>)+ , grabInt+ , grabText+ , pT+ , pS+ + -- * Working with URLs+ , getParam+ , matchUrl+ , generateUrl+ , findUrlMatch+ ) where+ import qualified Data.Text.Lazy as T import Data.Text.Lazy.Read import Data.Typeable@@ -10,17 +31,73 @@ import Web.Wheb.Types +-- * Convenience constructors++rGET :: (Maybe T.Text) -> UrlPat -> WhebHandlerT g s m -> Route g s m+rGET n p = Route n (==GET) (compilePat p)++rPOST :: (Maybe T.Text) -> UrlPat -> WhebHandlerT g s m -> Route g s m+rPOST n p = Route n (==POST) (compilePat p)++-- * URL Patterns++-- | Convert a 'UrlPat' to a 'UrlParser'+compilePat :: UrlPat -> UrlParser+compilePat (Composed a) = UrlParser (matchPat a) (buildPat a)+compilePat a = UrlParser (matchPat [a]) (buildPat [a])++-- | Represents root path @/@+rootPat :: UrlPat+rootPat = Composed [] ++++-- | Allows for easier building of URL patterns+-- This should be the primary URL constructor.+-- +-- @+-- (\"blog\" '</>' ('grabInt' \"pk\") '</>' \"edit\" '</>' ('grabText' \"verb\"))+-- @+(</>) :: UrlPat -> UrlPat -> UrlPat+(Composed a) </> (Composed b) = Composed (a ++ b)+a </> (Composed b) = Composed (a:b)+(Composed a) </> b = Composed (a ++ [b])+a </> b = Composed [a, b]++-- | Parses URL parameter and matches on 'Int'+grabInt :: T.Text -> UrlPat+grabInt key = FuncChunk key f IntChunk+ where rInt = decimal :: Reader Int+ f = ((either (const Nothing) (Just . MkChunk . fst)) . rInt)++-- | Parses URL parameter and matches on 'Text'+grabText :: T.Text -> UrlPat+grabText key = FuncChunk key (Just . MkChunk) TextChunk++-- | Constructors to use w/o OverloadedStrings+pT :: T.Text -> UrlPat+pT = Chunk++pS :: String -> UrlPat+pS = pT . T.pack++++-- | Lookup and cast a URL parameter to its expected type if it exists. getParam :: Typeable a => T.Text -> RouteParamList -> Maybe a getParam k l = (lookup k l) >>= unwrap where unwrap :: Typeable a => ParsedChunk -> Maybe a unwrap (MkChunk a) = cast a- ++-- | Convert URL chunks (split on /) matchUrl :: [T.Text] -> UrlParser -> Maybe RouteParamList matchUrl url (UrlParser f _) = f url +-- | Runs a 'UrlParser' with 'RouteParamList' to a URL path generateUrl :: UrlParser -> RouteParamList -> Either UrlBuildError T.Text generateUrl (UrlParser _ f) = f +-- | Sort through a list of routes to find a Handler and 'RouteParamList' findUrlMatch :: StdMethod -> [T.Text] -> [Route g s m] ->@@ -32,35 +109,7 @@ Just params -> Just (h, params) Nothing -> findUrlMatch rmtd path rs ---------- Url Patterns --------------- | Constructors to use w/o OverloadedStrings-pT :: T.Text -> UrlPat-pT = Chunk--pS :: String -> UrlPat-pS = pT . T.pack---- | Represents root (/)-rootPat :: UrlPat-rootPat = Composed [] --grabText :: T.Text -> UrlPat-grabText key = FuncChunk key (Just . MkChunk) TextChunk--grabInt :: T.Text -> UrlPat-grabInt key = FuncChunk key f IntChunk- where rInt = decimal :: Reader Int- f = ((either (const Nothing) (Just . MkChunk . fst)) . rInt)---- | Allows for easier building of URL patterns--- This should be the primary URL constructor.-(</>) :: UrlPat -> UrlPat -> UrlPat-(Composed a) </> (Composed b) = Composed (a ++ b)-a </> (Composed b) = Composed (a:b)-(Composed a) </> b = Composed (a ++ [b])-a </> b = Composed [a, b]- --- | Implementation for a UrlParser using pseudo-typed URL composition.+-- | Implementation for a 'UrlParser' using pseudo-typed URL composition. -- Pattern will match path when the pattern is as long as the path, matching -- on a trailing slash. If the path is longer or shorter than the pattern, it -- should not match.@@ -88,16 +137,12 @@ where build acc [] = Right acc build acc ((Chunk c):cs) = build (acc <> [c]) cs build acc ((Composed xs):cs) = build acc (xs <> cs)- build acc ((FuncChunk k f t):cs) = + build acc ((FuncChunk k _ t):cs) = case (showParam t k params) of (Right v) -> build (acc <> [v]) cs (Left err) -> Left err slash = (T.pack "/") addSlashes list = slash <> (T.intercalate slash list) <> slash--compilePat :: UrlPat -> UrlParser-compilePat (Composed a) = UrlParser (matchPat a) (buildPat a)-compilePat a = UrlParser (matchPat [a]) (buildPat [a]) showParam :: ChunkType -> T.Text -> RouteParamList -> Either UrlBuildError T.Text showParam chunkType k l =
Web/Wheb/Types.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Web.Wheb.Types where import Blaze.ByteString.Builder (Builder, fromLazyByteString)@@ -30,22 +31,40 @@ import Data.ByteString (ByteString) ++-- | WhebT g s m+--+-- * g -> The global confirgured context (Read-only data shared between threads)+-- +-- * s -> Request state initailized at the start of each request using Default+--+-- * m -> Monad we are transforming+newtype WhebT g s m a = WhebT + { runWhebT :: ErrorT WhebError + (ReaderT (HandlerData g s m) (StateT (InternalState s) m)) a + } deriving ( Functor, Applicative, Monad, MonadIO )++instance MonadTrans (WhebT g s) where+ lift = WhebT . lift . lift . lift++instance (Monad m) => MonadError WhebError (WhebT g s m) where+ throwError = WhebT . throwError+ catchError (WhebT m) f = WhebT (catchError m (runWhebT . f))++-- | Writer Monad to build options.+newtype InitM g s m a = InitM { runInitM :: WriterT (InitOptions g s m) IO a}+ deriving (Functor, Applicative, Monad, MonadIO)++-- | Converts a type to a WAI 'Response' class WhebContent a where toResponse :: Status -> ResponseHeaders -> a -> Response -data HandlerResponse = forall a . WhebContent a => HandlerResponse Status a-data WhebFile = WhebFile FilePath-type EResponse = Either WhebError Response-data SettingsValue = forall a. (Typeable a) => MkVal a-type CSettings = M.Map T.Text SettingsValue-data WhebError = Error500 String - | Error404 - | URLError T.Text UrlBuildError- deriving (Show)+-- | A Wheb response that represents a file.+data WhebFile = WhebFile T.Text -instance Error WhebError where - strMsg = Error500+data HandlerResponse = forall a . WhebContent a => HandlerResponse Status a +-- | Our 'ReaderT' portion of 'WhebT' uses this. data HandlerData g s m = HandlerData { globalCtx :: g , request :: Request@@ -53,19 +72,38 @@ , routeParams :: RouteParamList , globalSettings :: WhebOptions g s m } +-- | Our 'StateT' portion of 'WhebT' uses this. data InternalState s = InternalState { reqState :: s , respHeaders :: M.Map HeaderName ByteString } + +data SettingsValue = forall a. (Typeable a) => MkVal a +data WhebError = Error500 String + | Error404+ | Error403+ | URLError T.Text UrlBuildError+ deriving (Show)++instance Error WhebError where + strMsg = Error500+ instance Default s => Default (InternalState s) where def = InternalState def def +-- | Monoid to use in InitM's WriterT data InitOptions g s m = InitOptions { initRoutes :: [ Route g s m ] , initSettings :: CSettings , initWaiMw :: Middleware , initWhebMw :: [ WhebMiddleware g s m ] } +instance Monoid (InitOptions g s m) where+ mappend (InitOptions a1 b1 c1 d1) (InitOptions a2 b2 c2 d2) = + InitOptions (a1 <> a2) (b1 <> b2) (c2 . c1) (d1 <> d2)+ mempty = InitOptions mempty mempty id mempty++-- | The main option datatype for Wheb data WhebOptions g s m = MonadIO m => WhebOptions { appRoutes :: [ Route g s m ] , runTimeSettings :: CSettings@@ -75,37 +113,22 @@ , whebMiddlewares :: [ WhebMiddleware g s m ] , defaultErrorHandler :: WhebError -> WhebHandlerT g s m } -instance Monoid (InitOptions g s m) where- mappend (InitOptions a1 b1 c1 d1) (InitOptions a2 b2 c2 d2) = - InitOptions (a1 <> a2) (b1 <> b2) (c2 . c1) (d1 <> d2)- mempty = InitOptions mempty mempty id mempty--newtype InitM g s m a = InitM { runInitM :: WriterT (InitOptions g s m) IO a}- deriving (Functor, Applicative, Monad, MonadIO)---- | WhebT g s m--- g -> The global confirgured context (Read-only data shared between threads)--- s -> State initailized at the start of each request using Default--- m -> Monad we are transforming-newtype WhebT g s m a = WhebT - { runWhebT :: ErrorT WhebError - (ReaderT (HandlerData g s m) (StateT (InternalState s) m)) a - } deriving ( Functor, Applicative, Monad, MonadIO )--instance MonadTrans (WhebT g s) where- lift = WhebT . lift . lift . lift--instance (Monad m) => MonadError WhebError (WhebT g s m) where- throwError = WhebT . throwError- catchError (WhebT m) f = WhebT (catchError m (runWhebT . f))+type EResponse = Either WhebError Response -type MinWheb a = WhebT () () IO a-type MinOpts = WhebOptions () () IO+type CSettings = M.Map T.Text SettingsValue+ 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)------------------ Routes ----------------- +-- | A minimal type for WhebT+type MinWheb a = WhebT () () IO a++-- | A minimal type for WhebOptions+type MinOpts = WhebOptions () () IO++-- * Routes+ type RouteParamList = [(T.Text, ParsedChunk)] type MethodMatch = StdMethod -> Bool @@ -127,9 +150,12 @@ data ChunkType = IntChunk | TextChunk -data UrlPat = Chunk T.Text - | FuncChunk T.Text (T.Text -> Maybe ParsedChunk) ChunkType+data UrlPat = Chunk T.Text | Composed [UrlPat]+ | FuncChunk + { chunkParamName :: T.Text+ , chunkFunc :: (T.Text -> Maybe ParsedChunk)+ , chunkType :: ChunkType } instance IsString UrlPat where fromString = Chunk . T.pack
Web/Wheb/Utils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module Web.Wheb.Utils where import Blaze.ByteString.Builder (Builder@@ -19,6 +20,7 @@ lazyTextToSBS = TS.encodeUtf8 . T.toStrict sbsToLazyText = T.fromStrict . TS.decodeUtf8 +-- | See a 'HandlerResponse's as 'Text' showResponseBody :: HandlerResponse -> IO T.Text showResponseBody (HandlerResponse s r) = liftM (T.decodeUtf8 . toLazyByteString) builderBody@@ -35,7 +37,8 @@ toResponse s hds = responseBuilder s hds . fromLazyByteString . T.encodeUtf8 instance WhebContent WhebFile where- toResponse s hds (WhebFile fp) = responseFile s hds fp Nothing+ toResponse s hds (WhebFile fp) = responseFile s hds (show fp) Nothing+ ----------------------- Some defaults ----------------------- defaultErr :: Monad m => WhebError -> WhebHandlerT g s m defaultErr err = return $ HandlerResponse status500 $
Web/Wheb/WhebT.hs view
@@ -1,6 +1,50 @@ {-# LANGUAGE RecordWildCards #-} -module Web.Wheb.WhebT where+module Web.Wheb.WhebT+ (+ -- * ReaderT and StateT Functionality+ -- ** ReaderT+ getApp+ , getWithApp+ -- ** StateT+ , getReqState+ , putReqState+ , modifyReqState+ , modifyReqState'+ + -- * Responses+ , setHeader+ , setRawHeader+ , html+ , text+ , file+ + -- * Settings+ , getSetting+ , getSetting'+ , getSettings+ + -- * Routes+ , getRouteParams+ , getRouteParam+ , getRoute+ , getRoute'+ + -- * Request reading+ , getRequest+ , getRequestHeader+ , getWithRequest+ , getQueryParams+ , getPOSTParam+ , getPOSTParams+ , getRawPOST+ + -- * Running Wheb+ , runWhebServer+ , runWhebServerT+ , debugHandler+ , debugHandlerT+ )where import Control.Monad.Error import Control.Monad.IO.Class@@ -27,12 +71,23 @@ import Web.Wheb.Types import Web.Wheb.Utils +-- * ReaderT and StateT Functionality++-- ** ReaderT++-- | Get the 'g' in @WhebT g s m g@. This is a read-only state so only+-- thread-safe resources such as DB connections should go in here. 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 +-- ** StateT++-- | Get the 's' in @WhebT g s m g@. This is a read and writable state+-- so you can get and put information in your state. Each request gets its own+-- fresh state generated from "Default" getReqState :: Monad m => WhebT g s m s getReqState = WhebT $ liftM reqState get @@ -48,25 +103,41 @@ modifyReqState' :: Monad m => (s -> s) -> WhebT g s m () modifyReqState' f = modifyReqState f >> (return ()) +-- * Settings+ -- | Help prevent monomorphism errors for simple settings. getSetting :: Monad m => T.Text -> WhebT g s m (Maybe T.Text) getSetting = getSetting' --- | Open up underlying support for Polymorphic global settings+-- | Open up underlying support for polymorphic global settings getSetting' :: (Monad m, Typeable a) => T.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 +-- | Get all settings. getSettings :: Monad m => WhebT g s m CSettings getSettings = WhebT $ liftM (runTimeSettings . globalSettings) ask +-- * Routes++-- | Get all route params. getRouteParams :: Monad m => WhebT g s m RouteParamList getRouteParams = WhebT $ liftM routeParams ask +-- | Cast a route param into its type. getRouteParam :: (Typeable a, Monad m) => T.Text -> WhebT g s m (Maybe a) getRouteParam t = liftM (getParam t) getRouteParams +-- | 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+ case res of+ Right t -> return t+ Left err -> throwError $ URLError t err++-- | Generate a route from a name and param list. getRoute' :: Monad m => T.Text -> RouteParamList -> WhebT g s m (Either UrlBuildError T.Text)@@ -76,62 +147,71 @@ buildRoute (Nothing) = Left UrlNameNotFound f = (buildRoute . (find findRoute) . appRoutes . globalSettings) -getRoute :: Monad m => T.Text -> RouteParamList -> WhebT g s m T.Text-getRoute t l = do- res <- getRoute' t l- case res of- Right t -> return t- Left err -> throwError $ URLError t err+-- * Request reading +-- | Access the request 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 +-- | Get the raw parsed POST data including files. getRawPOST :: MonadIO m => WhebT g s m ([Param], [File LBS.ByteString]) getRawPOST = WhebT $ liftM postData ask +-- | Get POST params as 'Text' getPOSTParams :: MonadIO m => WhebT g s m [(T.Text, T.Text)] getPOSTParams = liftM (fmap f . fst) getRawPOST where f (a, b) = (sbsToLazyText a, sbsToLazyText b) -getPostParam :: MonadIO m => T.Text -> WhebT g s m (Maybe T.Text)-getPostParam k = liftM (lookup k) getPOSTParams +-- | Maybe get one param if it exists.+getPOSTParam :: MonadIO m => T.Text -> WhebT g s m (Maybe T.Text)+getPOSTParam k = liftM (lookup k) getPOSTParams +-- | Get params from URL (e.g. from '/foo/?q=4') getQueryParams :: Monad m => WhebT g s m Query getQueryParams = getWithRequest queryString -getHeader :: Monad m => T.Text -> WhebT g s m (Maybe T.Text)-getHeader k = getRequest >>= f+-- | Get a request header+getRequestHeader :: Monad m => T.Text -> WhebT g s m (Maybe T.Text)+getRequestHeader k = getRequest >>= f where hk = mk $ lazyTextToSBS k f = (return . (fmap sbsToLazyText) . (lookup hk) . requestHeaders) +-- * Responses++-- | Set a Strict ByteString header for the response 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 }-+ +-- | Set a header for the response setHeader :: Monad m => T.Text -> T.Text -> WhebT g s m () setHeader hn hc = setRawHeader (mk $ lazyTextToSBS hn, lazyTextToSBS hc) -- | Give filepath and content type to serve a file from disk.-file :: Monad m => FilePath -> T.Text -> WhebHandlerT g s m+file :: Monad m => T.Text -> T.Text -> WhebHandlerT g s m file fp ct = do setHeader (T.pack "Content-Type") (ct) return $ HandlerResponse status200 (WhebFile fp)- ++-- | Return simple HTML from Text html :: Monad m => T.Text -> WhebHandlerT g s m html c = do setHeader (T.pack "Content-Type") (T.pack "text/html") return $ HandlerResponse status200 c- ++-- | Return simple Text text :: Monad m => T.Text -> WhebHandlerT g s m text c = do setHeader (T.pack "Content-Type") (T.pack "text/plain") return $ HandlerResponse status200 c ------------------------ Running the application -----------------------+-- * Running a Wheb Application++-- | Running a Handler with a custom Transformer debugHandlerT :: (Default s) => WhebOptions g s m -> (m (Either WhebError a) -> IO (Either WhebError a)) -> Request ->@@ -141,11 +221,14 @@ runIO $ runDebugHandler opts h baseData where baseData = HandlerData startingCtx r ([], []) [] opts -debugHandlerIO :: (Default s) => WhebOptions g s IO -> +-- | Convenience wrapper for 'debugHandlerT' function in 'IO'+debugHandler :: (Default s) => WhebOptions g s IO -> WhebT g s IO a -> IO (Either WhebError a)-debugHandlerIO opts h = debugHandlerT opts id defaultRequest h+debugHandler opts h = debugHandlerT opts id defaultRequest h +-- | Run a server with a function to run your inner Transformer to IO and +-- generated options runWhebServerT :: (Default s) => (m EResponse -> IO EResponse) -> WhebOptions g s m ->@@ -156,6 +239,7 @@ waiStack $ optsToApplication opts runIO +-- | Convenience wrapper for 'runWhebServerT' function in IO runWhebServer :: (Default s) => (WhebOptions g s IO) -> IO ()
Wheb.cabal view
@@ -1,57 +1,80 @@--- Initial Wheb.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/---- The name of the package. name: Wheb---- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy--- PVP summary: +-+------- breaking API changes--- | | +----- non-breaking API additions--- | | | +--- code changes with no API change-version: 0.0.1.0---- A short (one-line) description of the package.-synopsis: The easy Haskell WAI Framework---- A longer description of the package.--- description: ---- URL for the project homepage or repository.-homepage: https://github.com/hansonkd/Wheb-Framework---- The license under which the package is released.+version: 0.0.1.1+synopsis: The Batteries-Included Haskell WAI Framework license: BSD3---- The file containing the license text. license-file: LICENSE---- The package author(s). author: Kyle Hanson---- An email address to which users can send suggestions, bug reports, and --- patches.+homepage: https://github.com/hansonkd/Wheb-Framework maintainer: hanooter@gmail.com---- A copyright notice.--- copyright: - category: Web- build-type: Simple---- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.8-+description: + Wheb aims at providing a simple simple and straightforward web server.+ .+ > import Web.Wheb+ > import Data.Text.Lazy (pack)+ >+ > main :: IO ()+ > main = do+ > opts <- generateOptions $ addGET (pack ".") rootPat $ (text (pack "Hi!"))+ > runWhebServer (opts :: MinOpts)+ . + Wheb makes it easy to share a global context and handle requests statefully+ .+ >+ > import Control.Concurrent.STM+ > import Control.Monad.IO.Class+ > import Data.Monoid+ > import Data.Text.Lazy (Text, pack)+ > import Web.Wheb+ >+ > data MyApp = MyApp Text (TVar Int)+ > data MyHandlerData = MyHandlerData Int+ >+ > instance Default MyHandlerData where+ > def = MyHandlerData 0+ >+ > counterMw :: MonadIO m => WhebMiddleware MyApp MyHandlerData m+ > counterMw = do+ > (MyApp _ ctr) <- getApp+ > number <- liftIO $ readTVarIO ctr+ > liftIO $ atomically $ writeTVar ctr (succ number)+ > putReqState (MyHandlerData number)+ > return Nothing+ >+ > homePage :: WhebHandler MyApp MyHandlerData+ > homePage = do+ > (MyApp appName _) <- getApp+ > (MyHandlerData num) <- getReqState+ > html $ ("<h1>Welcome to" <> appName <> + > "</h1><h2>You are visitor #" <> (pack $ show num) <> "</h2>")+ >+ > main :: IO ()+ > main = do+ > opts <- generateOptions $ do+ > startingCounter <- liftIO $ newTVarIO 0+ > addWhebMiddleware counterMw+ > addGET (pack ".") rootPat $ homePage+ > return $ MyApp "AwesomeApp" startingCounter+ > runWhebServer opts+ .+ Wheb allows you to write robust high concurrency web applications simply and effectively.+ .+ * The core datatype will allow you to build anything from a read-only server to a fully interactive web application with hundreds of routes without needing to define MonadTransformers.+ .+ * Minimal boilerplate to start your application.+ .+ * Plugin system+ .+ +source-repository head+ type: git+ location: git://github.com/hansonkd/Wheb-Framework.git library- -- Modules exported by the library. 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 - -- Modules included in this library but not exported.- -- other-modules: - - -- Other library packages from which modules are imported. build-depends: base ==4.6.*, text ==0.11.*, transformers ==0.3.*, data-default ==0.5.*, 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.*, uuid ==1.3.*, stm ==2.4.*+ GHC-options: -Wall -fno-warn-orphans