packages feed

Wheb 0.0.1.1 → 0.1.0.0

raw patch · 24 files changed

+1545/−1313 lines, 24 filesdep +HUnitdep +QuickCheckdep +Whebdep −data-default

Dependencies added: HUnit, QuickCheck, Wheb, test-framework, test-framework-hunit, test-framework-quickcheck2, unix

Dependencies removed: data-default

Files

− Web/Wheb.hs 
@@ -1,104 +0,0 @@-{-|--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 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Web.Wheb.Cookie-  ( setCookie-  , setCookie'-  , getCookie-  , getCookies-  , 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--getDefaultCookie :: Monad m => WhebT g s m SetCookie-getDefaultCookie = return def -- Populate with settings...--setCookie :: Monad m => Text -> Text -> WhebT g s m ()-setCookie k v = getDefaultCookie >>= (setCookie' k v)--setCookie' :: Monad m => Text -> Text -> SetCookie -> WhebT g s m ()-setCookie' k v sc = setRawHeader ("Set-Cookie", cookieText)-  where cookie = sc { setCookieName = lazyTextToSBS k-                    , setCookieValue = lazyTextToSBS v-                    }-        cookieText = B.toByteString $ renderSetCookie cookie-        -getCookies :: Monad m => WhebT g s m CookiesText-getCookies = (getRequestHeader "Cookie") >>= -             (return . parseFunc . (fromMaybe T.empty))-  where parseFunc = parseCookiesText . lazyTextToSBS--getCookie :: Monad m => Text -> WhebT g s m (Maybe Text)-getCookie k = getCookies >>= -    (return . (fmap T.fromStrict) . (lookup (T.toStrict k)))--removeCookie :: Monad m => Text -> WhebT g s m ()-removeCookie k = do-  defCookie <- getDefaultCookie-  let utcLongAgo = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)-      expiredCookie = defCookie {setCookieExpires = Just utcLongAgo}-  setCookie' k T.empty expiredCookie
− Web/Wheb/InitM.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--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-import qualified Data.Map as M-import qualified Data.Text.Lazy as T-import           Data.Typeable-import           Network.Wai-import           Network.Wai.Handler.Warp (defaultSettings)-import           Network.HTTP.Types.Method--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 $ 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--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 }---- | 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 "/*"))---- | Add generic "WAI" middleware-addWAIMiddleware :: Middleware -> InitM g s m ()-addWAIMiddleware m = InitM $ tell $ mempty { initWaiMw = m }---- | Add "Wheb" specific middleware-addWhebMiddleware :: WhebMiddleware g s m -> InitM g s m ()-addWhebMiddleware m = InitM $ tell $ mempty { initWhebMw = [m] }----- | 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)-  return $ WhebOptions { appRoutes = initRoutes-                         , runTimeSettings = initSettings-                         , warpSettings = defaultSettings-                         , startingCtx = g-                         , waiStack = initWaiMw-                         , whebMiddlewares = initWhebMw-                         , defaultErrorHandler = defaultErr }
− Web/Wheb/Internal.hs 
@@ -1,110 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--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           Data.Default-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---- * Converting to WAI application-                      --- | Convert 'WhebOptions' to 'Application'                        -optsToApplication :: (Default s) => WhebOptions g s m ->-                     (m EResponse -> IO EResponse) ->-                     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-        pathChunks = fmap T.fromStrict $ pathInfo r-        stdMthd    = either (\_-> GET) id $ parseMethod $ requestMethod r-        handleError err = do-          errRes <- runIO $ -                    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] ->-                  HandlerData g s m ->-                  m (Maybe Response, InternalState s)-runMiddlewares opts mWs hd = loop mWs def-    where loop [] st = return (Nothing, st)-          loop (mw:mws) st = do-                  mwResult <-  (runWhebMiddleware opts st hd mw)-                  case mwResult of-                        (Just resp, nst) -> return mwResult-                        (Nothing, nst)   -> loop mws nst--runWhebMiddleware :: (Default s, Monad m) =>-                    WhebOptions g s m ->-                    InternalState s ->-                    HandlerData g s m ->-                    WhebMiddleware g s m ->-                    m (Maybe Response, InternalState s)-runWhebMiddleware opts@(WhebOptions {..}) st hd mW = do-        (eresp, is@InternalState {..}) <- flip runStateT st $ do-                  flip runReaderT hd $-                    runErrorT $-                    runWhebT mW-        return $ (convertResponse respHeaders eresp, is)-  where convertResponse hds (Right (Just (HandlerResponse status resp))) =-                              Just (toResponse status (M.toList hds) resp)-        convertResponse _ _ = Nothing
− Web/Wheb/Plugins/Auth.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}--module Web.Wheb.Plugins.Auth -  ( -  -- * Main functions-    login-  , logout-  , register-  , getCurrentUser-  , queryCurrentUser-  , loginRequired-  -  -- * Middleware-  , authMiddleware -  -  -- * Types-  , AuthUser (..)-  , AuthContainer (..)-  , AuthApp (..)-  , AuthState (..)-  , AuthBackend (..)-  , AuthError (..)--  , UserKey-  , Password-  , PwHash-  -  -- * 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-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-    --- * 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--data AuthError = DuplicateUsername | UserDoesNotExist | InvalidPassword-  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) -> -                    WhebT a s m b-runWithContainer f = do-  AuthContainer authStore <- getWithApp getAuthContainer-  f authStore--authSetUser :: (AuthApp a, AuthState b, MonadIO m) => PossibleUser -> WhebT a b m ()-authSetUser cur = modifyReqState' (modifyAuthUser (const cur))--getUserSessionKey :: (AuthApp a, MonadIO m) => WhebT a b m Text-getUserSessionKey = return $ T.pack "user-id" -- later read from settings.--makePwHash :: MonadIO m => Password -> WhebT a b m PwHash-makePwHash pw = liftM (T.fromStrict . ES.decodeUtf8) $ -                        liftIO $ makePassword (ES.encodeUtf8 $ T.toStrict pw) 14--verifyPw :: Text -> Text -> Bool-verifyPw pw hash = verifyPassword (ES.encodeUtf8 $ T.toStrict pw) -                          (ES.encodeUtf8 $ T.toStrict hash)
− Web/Wheb/Plugins/Debug/MemoryBackend.hs 
@@ -1,70 +0,0 @@-module Web.Wheb.Plugins.Debug.MemoryBackend where--import Control.Monad (liftM)-import Control.Monad.IO.Class-import Control.Concurrent.STM-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--data SessionData = SessionData -  { sessionMemory ::  TVar (M.Map Text (M.Map Text Text)) }-data UserData = UserData-  { userStorage :: TVar (M.Map UserKey PwHash) }--- | In memory session backend. Session values --- will not persist after server restart.-instance SessionBackend SessionData where-  backendSessionPut sessId key content (SessionData tv) =-      let insertFunc = (\sess -> -                          Just $ M.insert key content (fromMaybe M.empty sess)-                       )-          tVarFunc = M.alter insertFunc sessId-      in liftIO $ atomically $ modifyTVar tv tVarFunc-  backendSessionGet sessId key (SessionData tv) = do-      curSessions <- liftIO $ readTVarIO tv-      return $ (M.lookup sessId curSessions) >>= (M.lookup key)-  backendSessionDelete sessId key (SessionData tv) =-      liftIO $ atomically $ modifyTVar tv (M.update (Just . (M.delete key)) sessId)-  backendSessionClear sessId (SessionData tv) =-      liftIO $ atomically $ modifyTVar tv (M.delete sessId)---- | In memory auth backend. User values --- will not persist after server restart.-instance AuthBackend UserData where-  backendGetUser name (UserData tv) = do-        possUser <- liftM (M.lookup name) $ liftIO $ readTVarIO tv-        case possUser of-          Nothing -> return Nothing-          Just _ -> return $ Just (AuthUser name)-  backendLogin name pw (UserData tv) = do-        users <- liftIO $ readTVarIO $ tv-        let possUser = M.lookup name users-            passCheck = fmap (verifyPw pw) possUser-        case passCheck of-            Just True -> return (Right $ AuthUser $ name)-            Just False -> return (Left InvalidPassword)-            Nothing -> return (Left UserDoesNotExist)-  backendRegister name pw (UserData tv) = do-        users <- liftIO $ readTVarIO $ tv-        if M.member name users-            then return (Left DuplicateUsername)-            else do-                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-  tv <- liftIO $ newTVarIO $ M.empty-  return $! SessionContainer $ SessionData tv--initAuthMemory :: InitM g s m AuthContainer-initAuthMemory = do-  tv <- liftIO $ newTVarIO $ M.empty-  return $! AuthContainer $ UserData tv
− Web/Wheb/Plugins/Session.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}--module Web.Wheb.Plugins.Session -  ( SessionContainer (..)-  , SessionApp (..)-  , SessionBackend (..)-  -  , setSessionValue-  , getSessionValue-  , getSessionValue'-  , deleteSessionValue-  , generateSessionKey-  , getCurrentSessionKey-  , 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---- | Initial pass on abstract plugin for Sessions.---   Possibly add support for Typable to ease typecasting.---session_cookie_key = pack "-session-"--data SessionContainer = forall r. SessionBackend r => SessionContainer r--class SessionApp a where-  getSessionContainer :: a -> SessionContainer--class SessionBackend c where-  backendSessionPut :: (SessionApp a, MonadIO m) => Text -> Text -> Text -> c -> WhebT a b m ()-  backendSessionGet :: (SessionApp a, MonadIO m) => Text -> Text -> c -> WhebT a b m (Maybe Text)-  backendSessionDelete :: (SessionApp a, MonadIO m) => Text -> Text -> c -> WhebT a b m ()-  backendSessionClear :: (SessionApp a, MonadIO m) => Text -> c -> WhebT a b m ()--runWithContainer :: (SessionApp a, MonadIO m) => (forall r. SessionBackend r => r -> WhebT a s m b) -> WhebT a s m b-runWithContainer f = do-  SessionContainer sessStore <- getWithApp getSessionContainer-  f sessStore--deleteSessionValue :: (SessionApp a, MonadIO m) => Text -> WhebT a b m ()-deleteSessionValue key= do-      sessId <- getCurrentSessionKey -      runWithContainer $ backendSessionDelete sessId key--setSessionValue :: (SessionApp a, MonadIO m) => Text -> Text -> WhebT a b m ()-setSessionValue key content = do-      sessId <- getCurrentSessionKey -      runWithContainer $ backendSessionPut sessId key content--getSessionValue :: (SessionApp a, MonadIO m) => Text -> WhebT a b m (Maybe Text)-getSessionValue key = do-      sessId <- getCurrentSessionKey-      runWithContainer $ backendSessionGet sessId key--getSessionValue' :: (SessionApp a, MonadIO m) => Text -> Text -> WhebT a b m Text-getSessionValue' def key = liftM (fromMaybe def) (getSessionValue key)-      -getSessionCookie :: (SessionApp a, MonadIO m) => WhebT a b m (Maybe Text)-getSessionCookie = getCookie session_cookie_key-    -generateSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text-generateSessionKey = do-  newKey <- liftM (T.decodeUtf8 . toLazyASCIIBytes) (liftIO nextRandom)-  setCookie session_cookie_key newKey-  return newKey--getCurrentSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text-getCurrentSessionKey = do-    curKey <- getSessionCookie-    case curKey of-      Just key -> return key-      Nothing -> generateSessionKey--clearSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text-clearSessionKey = do-    curKey <- getSessionCookie-    newKey <- generateSessionKey-    case curKey of-      Nothing -> return newKey-      Just oldKey -> do-          runWithContainer $ backendSessionClear oldKey-          return newKey
− Web/Wheb/Routes.hs 
@@ -1,156 +0,0 @@-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-import           Network.HTTP.Types.Method--import           Data.Maybe (fromJust)-import           Data.Monoid ((<>))--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] ->-                Maybe (WhebHandlerT g s m, RouteParamList)-findUrlMatch _ _ [] = Nothing-findUrlMatch rmtd path ((Route _ methodMatch (UrlParser f _) h):rs) -      | not (methodMatch rmtd) =  findUrlMatch rmtd path rs-      | otherwise = case f path of-                        Just params -> Just (h, params)-                        Nothing -> findUrlMatch rmtd path rs---- | 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.---   Example:---       Given a url = "blog" </> (grabInt "pk") </> "edit"---       This will match on "/blog/1/edit" and /blog/9999/edit/"---       But not "/blog/1/", "/blog/1", "blog/foo/edit/", "/blog/9/edit/d",---       nor "/blog/9/edit//"-matchPat :: [UrlPat] ->  [T.Text] -> Maybe RouteParamList-matchPat chunks t = parse t chunks []-  where parse [] [] params = Just params-        parse [] c  params = Nothing-        parse (u:[])  [] params | T.null u  = Just params -- Match only 1 trailing slash-                                | otherwise = Nothing-        parse (u:us) [] _ = Nothing-        parse (u:us) ((Chunk c):cs) params | u == c    = parse us cs params-                                           | otherwise = Nothing-        parse (u:us) ((FuncChunk k f _):cs) params = do-                                            val <- f u-                                            parse us cs ((k, val):params)-        parse us ((Composed xs):cs) params = parse us (xs ++ cs) params--buildPat :: [UrlPat] -> RouteParamList -> Either UrlBuildError T.Text-buildPat pats params = fmap addSlashes $ build [] pats-    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 _ 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--showParam :: ChunkType -> T.Text -> RouteParamList -> Either UrlBuildError T.Text-showParam chunkType k l = -    case (lookup k l) of-        Just (MkChunk v) -> case chunkType of-            IntChunk -> toEither $ fmap (T.pack . show) (cast v :: Maybe Int)-            TextChunk -> toEither (cast v :: Maybe T.Text)-        Nothing -> Left NoParam-    where toEither v = case v of-                          Just b  -> Right b-                          Nothing -> Left $ ParamTypeMismatch k
− Web/Wheb/Types.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE MultiParamTypeClasses      #-}--module Web.Wheb.Types where--import           Blaze.ByteString.Builder (Builder, fromLazyByteString)-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.Default-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)----- | 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---- | A Wheb response that represents a file.-data WhebFile = WhebFile T.Text--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-              , postData       :: ([Param], [File LBS.ByteString])-              , 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-              , warpSettings        :: Warp.Settings-              , startingCtx         :: g-              , waiStack            :: Middleware-              , whebMiddlewares     :: [ WhebMiddleware g s m ]-              , defaultErrorHandler :: WhebError -> WhebHandlerT g s m }--type EResponse = Either WhebError Response--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)---- | 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--data ParsedChunk = forall a. (Typeable a, Show a) => MkChunk a--data UrlBuildError = NoParam | ParamTypeMismatch T.Text | UrlNameNotFound-     deriving (Show) ---- | A Parser should be able to extract params and regenerate URL from params.-data UrlParser = UrlParser -    { parseFunc :: ([T.Text] -> Maybe RouteParamList)-    , genFunc   :: (RouteParamList -> Either UrlBuildError T.Text) }--data Route g s m = Route -  { routeName    :: (Maybe T.Text)-  , routeMethod  :: MethodMatch-  , routeParser  :: UrlParser-  , routeHandler :: (WhebHandlerT g s m) }--data ChunkType = IntChunk | TextChunk--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 
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--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--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-    where chunkFlatAppend m (C.Chunk more) = m `mappend` more-          chunkFlatAppend m _ = m-          builderBody = body' (C.$$ fold chunkFlatAppend mempty)-          (_, _, body') = responseToSource $ toResponse s [] r------------------------- Instances -------------------------instance WhebContent Builder where-  toResponse = responseBuilder--instance WhebContent T.Text where-  toResponse s hds = responseBuilder s hds . fromLazyByteString . T.encodeUtf8--instance WhebContent WhebFile where-  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 $ -            ("<h1>Error: " <> (T.pack $ show err) <> ".</h1>")--uhOh :: Response-uhOh = responseLBS status500 [("Content-Type", "text/html")]-      "Something went wrong on the server."
− Web/Wheb/WhebT.hs 
@@ -1,246 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--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-import           Control.Monad.Reader-import           Control.Monad.State-import qualified Data.ByteString.Lazy as LBS-import           Data.CaseInsensitive (mk)-import           Data.Default-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           Web.Wheb.Internal-import           Web.Wheb.Routes-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--putReqState :: Monad m => s -> WhebT g s m ()-putReqState s = WhebT $ modify (\is -> is {reqState = s})--modifyReqState :: Monad m => (s -> s) -> WhebT g s m s-modifyReqState f = do-    s <- liftM f getReqState-    putReqState s-    return s--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-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)-getRoute' n l = WhebT $ liftM f ask-    where findRoute (Route {..}) = fromMaybe False (fmap (==n) routeName)-          buildRoute (Just (Route {..})) = generateUrl routeParser l-          buildRoute (Nothing)           = Left UrlNameNotFound-          f = (buildRoute . (find findRoute) . appRoutes . globalSettings)---- * 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)---- | 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---- | 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 => 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 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 ->-             WhebT g s m a ->-             IO (Either WhebError a)-debugHandlerT opts@(WhebOptions {..}) runIO r h = -    runIO $ runDebugHandler opts h baseData-    where baseData = HandlerData startingCtx r ([], []) [] opts---- | Convenience wrapper for 'debugHandlerT' function in 'IO'-debugHandler :: (Default s) => WhebOptions g s IO -> -              WhebT g s IO a ->-              IO (Either WhebError a)-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 ->-                  IO ()-runWhebServerT runIO opts@(WhebOptions {..}) = do-    putStrLn $ "Now running on port " ++ (show $ W.settingsPort $ warpSettings)-    runSettings warpSettings $ -        waiStack $ -        optsToApplication opts runIO---- | Convenience wrapper for 'runWhebServerT' function in IO-runWhebServer :: (Default s) => -                 (WhebOptions g s IO) ->-                 IO ()-runWhebServer = runWhebServerT id
Wheb.cabal view
@@ -1,6 +1,6 @@ name:                Wheb-version:             0.0.1.1-synopsis:            The Batteries-Included Haskell WAI Framework+version:             0.1.0.0+synopsis:            The frictionless WAI Framework license:             BSD3 license-file:        LICENSE author:              Kyle Hanson@@ -8,21 +8,63 @@ maintainer:          hanooter@gmail.com category:            Web build-type:          Simple-cabal-version:       >=1.8+cabal-version:       >=1.10 description:         -  Wheb aims at providing a simple simple and straightforward web server.+  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).+  .+  * Easy to use for REST APIs+  .+  * Fully database and template agnostic+  .+  * Easy handler debugging.+  .+  * Middleware+  .+  * Fast. It deploys on warp.+  .+  /Plugins:/+  .+  Wheb makes it easy to write plugins. Plugins can add routes, middlware, settings and even handle resource cleanup on server shutdown.+  Named routes allow plugins to dynamically generate their routes at runtime based on settings.+  .+  Examples of plugins:+  .+  * Sessions+  .+  * Auth+  .+  * <http://hackage.haskell.org/package/wheb-mongo Wheb-Mongo>+  .+  /Wheb in action:/+  .   > import           Web.Wheb   > import           Data.Text.Lazy (pack)   >   > main :: IO ()   > main = do-  >  opts <- generateOptions $ addGET (pack ".") rootPat $ (text (pack "Hi!"))-  >  runWhebServer (opts :: MinOpts)+  >   opts <- genMinOpts $ do+  >      addGET "home" rootPat $ (text (pack "Hi!"))+  >      addGET "about" ("about" </> "something") $ html (pack "<html><body><h1>About!</h1></body></html>")+  >   runWhebServer opts+  .+  /Bigger example (Stateful.hs):/   . -  Wheb makes it easy to share a global context and handle requests statefully+  Wheb makes it easy to share a global context and handle requests statefully. The Wheb monad+  is both a Reader and a State Monad allowing you to seperate thread-safe resources.   .-  >+  Below is an example of site that naively counts the non-unique hits across all pages. MyApp+  is our Reader's type and MyHandlerData is our State's type. MyApp is shared across requests+  while MyHandlerData is thread specific with a starting state given in options. We have a middleware+  that intercepts the request, safely increments the shared resource TVar and sets our MyHandlerData +  to the correct count before it reaches our handler. We use a TVar in the Global context +  because any state changes to the handler state will not affect other requests.+  .   >  import           Control.Concurrent.STM   >  import           Control.Monad.IO.Class   >  import           Data.Monoid@@ -32,23 +74,22 @@   >  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)+  >    number <- liftIO $ atomically $ do+  >            num <- readTVar ctr+  >            writeTVar ctr (succ num)+  >            return num+  >    putHandlerState (MyHandlerData number)   >    return Nothing   >   >  homePage :: WhebHandler MyApp MyHandlerData   >  homePage = do-  >    (MyApp appName _)       <- getApp-  >    (MyHandlerData num) <- getReqState+  >    (MyApp appName _)   <- getApp+  >    (MyHandlerData num) <- getHandlerState   >    html $ ("<h1>Welcome to" <> appName <> -  >            "</h1><h2>You are visitor #" <> (pack $ show num) <> "</h2>")+  >            "</h1><h2>You are visitor #" <> (spack num) <> "</h2>")   >   >  main :: IO ()   >  main = do@@ -56,25 +97,55 @@   >              startingCounter <- liftIO $ newTVarIO 0   >              addWhebMiddleware counterMw   >              addGET (pack ".") rootPat $ homePage-  >              return $ MyApp "AwesomeApp" startingCounter+  >              return $ (MyApp "AwesomeApp" startingCounter, MyHandlerData 0)   >    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+  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.*, 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.*+  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.*+  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.*, +                   HUnit >= 1.2 && < 2,+                   QuickCheck >= 2.4,+                   test-framework >= 0.4.1,+                   test-framework-quickcheck2,+                   test-framework-hunit,+                   text ==0.11.*++  ghc-options:     -Wall -rtsopts+  hs-source-dirs:  tests+  default-language: Haskell2010+  hs-source-dirs:  tests+  main-is:         Main.hs
+ src/Web/Wheb.hs view
@@ -0,0 +1,115 @@+{-|++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+@++-}+module Web.Wheb +  (+  -- * Handlers+  -- ** ReaderT and StateT Functionality+  -- *** ReaderT+    getApp+  , getWithApp+  -- *** StateT+  , getHandlerState+  , putHandlerState+  , modifyHandlerState+  , modifyHandlerState'+  +  -- ** Dealing with responses+  -- *** Creating a 'HandlerResponse'+  , html+  , text+  , file+  , builder+  -- *** Setting a header+  , setHeader+  , setRawHeader+  +  -- * Settings+  , getSetting+  , 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+  , addPUT+  , addDELETE+  -- *** Add raw routes+  , addRoute+  , addRoutes+  , catchAll+  -- ** Middlewares+  , addWAIMiddleware+  , addWhebMiddleware+  -- ** Settings+  , addSetting+  , addSetting'+  , addSettings+  , readSettingsFile+  -- ** Cleanup+  , addCleanupHook+  -- * Running+  , generateOptions+  , genMinOpts+  -- * Routes+  -- ** URL Patterns+  , compilePat+  , rootPat+  +  -- ** URL building+  , (</>)+  , grabInt+  , grabText+  , pT+  , pS+  -- * Utilities+  , spack+  , MonadIO(..)+  -- * Types+  , module Web.Wheb.Types+  ) 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
+ src/Web/Wheb/Cookie.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Wheb.Cookie+  ( setCookie+  , setCookie'+  , getCookie+  , getCookies+  , 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++getDefaultCookie :: Monad m => WhebT g s m SetCookie+getDefaultCookie = return def -- Populate with settings...++setCookie :: Monad m => Text -> Text -> WhebT g s m ()+setCookie k v = getDefaultCookie >>= (setCookie' k v)++setCookie' :: Monad m => Text -> Text -> SetCookie -> WhebT g s m ()+setCookie' k v sc = setRawHeader ("Set-Cookie", cookieText)+  where cookie = sc { setCookieName = lazyTextToSBS k+                    , setCookieValue = lazyTextToSBS v+                    }+        cookieText = B.toByteString $ renderSetCookie cookie+        +getCookies :: Monad m => WhebT g s m CookiesText+getCookies = (getRequestHeader "Cookie") >>= +             (return . parseFunc . (fromMaybe T.empty))+  where parseFunc = parseCookiesText . lazyTextToSBS++getCookie :: Monad m => Text -> WhebT g s m (Maybe Text)+getCookie k = getCookies >>= +    (return . (fmap T.fromStrict) . (lookup (T.toStrict k)))++removeCookie :: Monad m => Text -> WhebT g s m ()+removeCookie k = do+  defCookie <- getDefaultCookie+  let utcLongAgo = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)+      expiredCookie = defCookie {setCookieExpires = Just utcLongAgo}+  setCookie' k T.empty expiredCookie
+ src/Web/Wheb/InitM.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE RecordWildCards #-}++module Web.Wheb.InitM+  (+  -- * Routes+  -- ** Named routes convenience functions+    addGET+  , addPOST+  , addPUT+  , addDELETE+  -- ** Add raw routes+  , addRoute+  , addRoutes+  , catchAll+  -- * Middlewares+  , addWAIMiddleware+  , addWhebMiddleware+  -- * Settings+  , addSetting+  , addSetting'+  , addSettings+  , readSettingsFile+  -- * Cleanup+  , addCleanupHook+  -- * Running+  , 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 }++-- | 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+        where parser = UrlParser (const (Just [])) (const (Right $ T.pack "/*"))++-- | Add generic "WAI" middleware+addWAIMiddleware :: Middleware -> InitM g s m ()+addWAIMiddleware m = InitM $ tell $ mempty { initWaiMw = m }++-- | Add "Wheb" specific middleware+addWhebMiddleware :: WhebMiddleware g s m -> InitM g s m ()+addWhebMiddleware m = InitM $ tell $ mempty { initWhebMw = [m] }++-- | 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 }++-- | Reads a file line by line and splits keys and values by \":\".+--   Uses default "Text.Read" to try to match 'Int', 'Bool' or 'Float' and will add+--   specific typed settings for those.+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)++-- | IO Actions to run after server has been stopped.+addCleanupHook :: IO () -> InitM g s m ()+addCleanupHook action = InitM $ tell $ mempty { initCleanup = [action] }++-- | Generate 'WhebOptions' from 'InitM' in 'IO'+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)))++-- | Generate options for an application without a context or state+genMinOpts :: InitM () () IO () -> IO MinOpts+genMinOpts m = generateOptions (m >> (return ((), ())))
+ src/Web/Wheb/Internal.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards #-}++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++-- * Converting to WAI application+                      +-- | Convert 'WhebOptions' to 'Application'                        +optsToApplication :: WhebOptions g s m ->+                     (m EResponse -> IO EResponse) ->+                     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+        pathChunks = fmap T.fromStrict $ pathInfo r+        stdMthd    = either (\_-> GET) id $ parseMethod $ requestMethod r+        runErrorHandler eh = runWhebHandler opts eh startingState baseData+        handleError err = do+          errRes <- runIO $ runErrorHandler (defaultErrorHandler err)+          either (return . (const uhOh)) return errRes++-- * Running Handlers++-- | Run all inner wheb monads to the top level.+runWhebHandler :: 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 :: 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 startingState $ 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 :: Monad m =>+                  WhebOptions g s m ->+                  [WhebMiddleware g s m] ->+                  HandlerData g s m ->+                  m (Maybe Response, InternalState s)+runMiddlewares opts mWs hd = loop mWs (startingState opts)+    where loop [] st = return (Nothing, st)+          loop (mw:mws) st = do+                  mwResult <-  (runWhebMiddleware opts st hd mw)+                  case mwResult of+                        (Just resp, nst) -> return mwResult+                        (Nothing, nst)   -> loop mws nst++runWhebMiddleware :: Monad m =>+                    WhebOptions g s m ->+                    InternalState s ->+                    HandlerData g s m ->+                    WhebMiddleware g s m ->+                    m (Maybe Response, InternalState s)+runWhebMiddleware opts@(WhebOptions {..}) st hd mW = do+        (eresp, is@InternalState {..}) <- flip runStateT st $ do+                  flip runReaderT hd $+                    runErrorT $+                    runWhebT mW+        return $ (convertResponse respHeaders eresp, is)+  where convertResponse hds (Right (Just (HandlerResponse status resp))) =+                              Just (toResponse status (M.toList hds) resp)+        convertResponse _ _ = Nothing
+ src/Web/Wheb/Plugins/Auth.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++module Web.Wheb.Plugins.Auth +  ( +  -- * Main functions+    login+  , logout+  , register+  , getCurrentUser+  , queryCurrentUser+  , loginRequired+  +  -- * Middleware+  , authMiddleware +  +  -- * Types+  , AuthUser (..)+  , AuthContainer (..)+  , AuthApp (..)+  , AuthState (..)+  , AuthBackend (..)+  , AuthError (..)++  , UserKey+  , Password+  , PwHash+  +  -- * 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+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+    +-- * Auth functions++-- | Register a user+register :: (AuthApp a, MonadIO m) => AuthUser -> 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 handler state (Needs to be populated first+--   with 'authMiddleware')+getCurrentUser :: (AuthState b, MonadIO m) => WhebT a b m (Maybe AuthUser)+getCurrentUser = liftM getAuthUser getHandlerState++-- | 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 throws a 500+--   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 handler 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++data AuthError = DuplicateUsername | UserDoesNotExist | InvalidPassword+  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) => AuthUser -> 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) -> +                    WhebT a s m b+runWithContainer f = do+  AuthContainer authStore <- getWithApp getAuthContainer+  f authStore++authSetUser :: (AuthApp a, AuthState b, MonadIO m) => PossibleUser -> WhebT a b m ()+authSetUser cur = modifyHandlerState' (modifyAuthUser (const cur))++getUserSessionKey :: (AuthApp a, MonadIO m) => WhebT a b m Text+getUserSessionKey = return $ T.pack "user-id" -- later read from settings.++makePwHash :: MonadIO m => Password -> WhebT a b m PwHash+makePwHash pw = liftM (T.fromStrict . ES.decodeUtf8) $ +                        liftIO $ makePassword (ES.encodeUtf8 $ T.toStrict pw) 14++verifyPw :: Text -> Text -> Bool+verifyPw pw hash = verifyPassword (ES.encodeUtf8 $ T.toStrict pw) +                          (ES.encodeUtf8 $ T.toStrict hash)
+ src/Web/Wheb/Plugins/Debug/MemoryBackend.hs view
@@ -0,0 +1,71 @@+module Web.Wheb.Plugins.Debug.MemoryBackend where++import Control.Monad (liftM)+import Control.Monad.IO.Class+import Control.Concurrent.STM+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++data SessionData = SessionData +  { sessionMemory ::  TVar (M.Map Text (M.Map Text Text)) }+data UserData = UserData+  { userStorage :: TVar (M.Map UserKey PwHash) }++-- | In memory session backend. Session values +-- will not persist after server restart.+instance SessionBackend SessionData where+  backendSessionPut sessId key content (SessionData tv) =+      let insertFunc = (\sess -> +                          Just $ M.insert key content (fromMaybe M.empty sess)+                       )+          tVarFunc = M.alter insertFunc sessId+      in liftIO $ atomically $ modifyTVar tv tVarFunc+  backendSessionGet sessId key (SessionData tv) = do+      curSessions <- liftIO $ readTVarIO tv+      return $ (M.lookup sessId curSessions) >>= (M.lookup key)+  backendSessionDelete sessId key (SessionData tv) =+      liftIO $ atomically $ modifyTVar tv (M.update (Just . (M.delete key)) sessId)+  backendSessionClear sessId (SessionData tv) =+      liftIO $ atomically $ modifyTVar tv (M.delete sessId)++-- | In memory auth backend. User values +-- will not persist after server restart.+instance AuthBackend UserData where+  backendGetUser name (UserData tv) = do+        possUser <- liftM (M.lookup name) $ liftIO $ readTVarIO tv+        case possUser of+          Nothing -> return Nothing+          Just _ -> return $ Just (AuthUser name)+  backendLogin name pw (UserData tv) = do+        users <- liftIO $ readTVarIO $ tv+        let possUser = M.lookup name users+            passCheck = fmap (verifyPw pw) possUser+        case passCheck of+            Just True -> return (Right $ AuthUser $ name)+            Just False -> return (Left InvalidPassword)+            Nothing -> return (Left UserDoesNotExist)+  backendRegister (AuthUser name) pw (UserData tv) = do+        users <- liftIO $ readTVarIO $ tv+        if M.member name users+            then return (Left DuplicateUsername)+            else do+                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+  tv <- liftIO $ newTVarIO $ M.empty+  return $! SessionContainer $ SessionData tv++initAuthMemory :: InitM g s m AuthContainer+initAuthMemory = do+  tv <- liftIO $ newTVarIO $ M.empty+  return $! AuthContainer $ UserData tv
+ src/Web/Wheb/Plugins/Session.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++module Web.Wheb.Plugins.Session +  ( SessionContainer (..)+  , SessionApp (..)+  , SessionBackend (..)+  +  , setSessionValue+  , getSessionValue+  , getSessionValue'+  , deleteSessionValue+  , generateSessionKey+  , getCurrentSessionKey+  , 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++-- | Initial pass on abstract plugin for Sessions.+--   Possibly add support for Typable to ease typecasting.+++session_cookie_key = pack "-session-"++data SessionContainer = forall r. SessionBackend r => SessionContainer r++class SessionApp a where+  getSessionContainer :: a -> SessionContainer++class SessionBackend c where+  backendSessionPut    :: (SessionApp a, MonadIO m) => Text -> Text -> Text -> c -> WhebT a b m ()+  backendSessionGet    :: (SessionApp a, MonadIO m) => Text -> Text -> c -> WhebT a b m (Maybe Text)+  backendSessionDelete :: (SessionApp a, MonadIO m) => Text -> Text -> c -> WhebT a b m ()+  backendSessionClear  :: (SessionApp a, MonadIO m) => Text -> c -> WhebT a b m ()++runWithContainer :: (SessionApp a, MonadIO m) => (forall r. SessionBackend r => r -> WhebT a s m b) -> WhebT a s m b+runWithContainer f = do+  SessionContainer sessStore <- getWithApp getSessionContainer+  f sessStore++deleteSessionValue :: (SessionApp a, MonadIO m) => Text -> WhebT a b m ()+deleteSessionValue key= do+      sessId <- getCurrentSessionKey +      runWithContainer $ backendSessionDelete sessId key++setSessionValue :: (SessionApp a, MonadIO m) => Text -> Text -> WhebT a b m ()+setSessionValue key content = do+      sessId <- getCurrentSessionKey +      runWithContainer $ backendSessionPut sessId key content++getSessionValue :: (SessionApp a, MonadIO m) => Text -> WhebT a b m (Maybe Text)+getSessionValue key = do+      sessId <- getCurrentSessionKey+      runWithContainer $ backendSessionGet sessId key++getSessionValue' :: (SessionApp a, MonadIO m) => Text -> Text -> WhebT a b m Text+getSessionValue' def key = liftM (fromMaybe def) (getSessionValue key)+      +getSessionCookie :: (SessionApp a, MonadIO m) => WhebT a b m (Maybe Text)+getSessionCookie = getCookie session_cookie_key+    +generateSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text+generateSessionKey = do+  newKey <- liftM (T.decodeUtf8 . toLazyASCIIBytes) (liftIO nextRandom)+  setCookie session_cookie_key newKey+  return newKey++getCurrentSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text+getCurrentSessionKey = do+    curKey <- getSessionCookie+    case curKey of+      Just key -> return key+      Nothing -> generateSessionKey++clearSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text+clearSessionKey = do+    curKey <- getSessionCookie+    newKey <- generateSessionKey+    case curKey of+      Nothing -> return newKey+      Just oldKey -> do+          runWithContainer $ backendSessionClear oldKey+          return newKey
+ src/Web/Wheb/Routes.hs view
@@ -0,0 +1,168 @@+module Web.Wheb.Routes+  (+  -- * URL building+    (</>)+  , grabInt+  , grabText+  , pT+  , pS+  -- * Convenience constructors+  , patRoute+  -- * URL Patterns+  , compilePat+  , rootPat+  +  -- * Working with URLs+  , getParam+  , matchUrl+  , generateUrl+  , findUrlMatch++  -- * 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++-- | Build a 'Route' from a 'UrlPat'+patRoute :: (Maybe T.Text) -> +            StdMethod -> +            UrlPat -> +            WhebHandlerT g s m -> +            Route g s m+patRoute n m p = Route n (==m) (compilePat p)++-- | 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 = Chunk $ T.pack ""++-- | 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] ->+                Maybe (WhebHandlerT g s m, RouteParamList)+findUrlMatch _ _ [] = Nothing+findUrlMatch rmtd path ((Route _ methodMatch (UrlParser f _) h):rs) +      | not (methodMatch rmtd) =  findUrlMatch rmtd path rs+      | otherwise = case f path of+                        Just params -> Just (h, params)+                        Nothing -> findUrlMatch rmtd path rs++-- | Test a parser to make sure it can match what it produces and vice versa+testUrlParser :: UrlParser -> RouteParamList -> Bool+testUrlParser up rpl = +  case generateUrl up rpl of+      Left _ -> False+      Right t -> case (matchUrl (fmap T.fromStrict $ decodeUrl t) up) of+          Just params -> either (const False) (==t) (generateUrl up params)+          Nothing -> False+  where decodeUrl = decodePathSegments . lazyTextToSBS++-- | 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.+--   Example:+--       Given a url = "blog" </> (grabInt "pk") </> "edit"+--       This will match on "/blog/1/edit" and /blog/9999/edit/"+--       But not "/blog/1/", "/blog/1", "blog/foo/edit/", "/blog/9/edit/d",+--       nor "/blog/9/edit//"+matchPat :: [UrlPat] ->  [T.Text] -> Maybe RouteParamList+matchPat chunks [] = matchPat chunks [T.pack ""]+matchPat chunks t  = parse t chunks []+  where parse [] [] params = Just params+        parse [] c  params = Nothing+        parse (u:[]) [] params | T.null u  = Just params+                               | otherwise = Nothing+        parse (u:us) [] _ = Nothing+        parse (u:us) ((Chunk c):cs) params | T.null c  = parse (u:us) cs params+                                           | u == c    = parse us cs params+                                           | otherwise = Nothing+        parse (u:us) ((FuncChunk k f _):cs) params = do+                                            val <- f u+                                            parse us cs ((k, val):params)+        parse us ((Composed xs):cs) params = parse us (xs ++ cs) params++buildPat :: [UrlPat] -> RouteParamList -> Either UrlBuildError T.Text+buildPat pats params = fmap addSlashes $ build [] pats+    where build acc [] = Right acc+          build acc ((Chunk c):[]) = build (acc <> [c]) []+          build acc ((Chunk c):cs) | T.null c = build acc cs+                                   | otherwise = build (acc <> [c]) cs+          build acc ((Composed xs):cs)     = build acc (xs <> cs)+          build acc ((FuncChunk k _ t):cs) = +              case (showParam t k params) of+                      (Right  v)  -> build (acc <> [v]) cs+                      (Left err)  -> Left err+          addSlashes []   = T.pack "/"+          addSlashes list = builderToText $+                              encodePathSegments (fmap T.toStrict list)++showParam :: ChunkType -> T.Text -> RouteParamList -> Either UrlBuildError T.Text+showParam chunkType k l = +    case (lookup k l) of+        Just (MkChunk v) -> case chunkType of+            IntChunk -> toEither $ fmap spack (cast v :: Maybe Int)+            TextChunk -> toEither (cast v :: Maybe T.Text)+        Nothing -> Left NoParam+    where toEither v = case v of+                          Just b  -> Right b+                          Nothing -> Left $ ParamTypeMismatch k
+ src/Web/Wheb/Types.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++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)+++-- | WhebT g s m+--+--   * g -> The global confirgured context (Read-only data shared between threads)+-- +--   * s -> Handler state for each request.+--+--   * 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++-- | A Wheb response that represents a file.+data WhebFile = WhebFile T.Text++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+              , postData       :: ([Param], [File LBS.ByteString])+              , 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+               | RouteParamDoesNotExist+               | 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 ]+              , 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++-- | The main option datatype for Wheb+data WhebOptions g s m = MonadIO m => +  WhebOptions { appRoutes           :: [ Route g s m ]+              , runTimeSettings     :: CSettings+              , warpSettings        :: Warp.Settings+              , startingCtx         :: g -- ^ Global ctx shared between requests+              , startingState       :: InternalState s -- ^ Handler state given each request+              , waiStack            :: Middleware+              , whebMiddlewares     :: [ WhebMiddleware g s m ]+              , defaultErrorHandler :: WhebError -> WhebHandlerT g s m+              , shutdownTVar       :: TVar Bool+              , activeConnections   :: TVar Int+              , cleanupActions      :: [ IO () ] }++type EResponse = Either WhebError Response++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)++-- | A minimal type for WhebT+type MinWheb a = WhebT () () IO a+type MinHandler = MinWheb HandlerResponse+-- | A minimal type for WhebOptions+type MinOpts = WhebOptions () () IO++-- * Routes++type  RouteParamList = [(T.Text, ParsedChunk)]+type  MethodMatch = StdMethod -> Bool++data ParsedChunk = forall a. (Typeable a, Show a) => MkChunk a++instance Show ParsedChunk where+  show (MkChunk a) = show a++data UrlBuildError = NoParam | ParamTypeMismatch T.Text | UrlNameNotFound+     deriving (Show) ++-- | A Parser should be able to extract params and regenerate URL from params.+data UrlParser = UrlParser +    { parseFunc :: ([T.Text] -> Maybe RouteParamList)+    , genFunc   :: (RouteParamList -> Either UrlBuildError T.Text) }++data Route g s m = Route +  { routeName    :: (Maybe T.Text)+  , routeMethod  :: MethodMatch+  , routeParser  :: UrlParser+  , routeHandler :: (WhebHandlerT g s m) }++data ChunkType = IntChunk | TextChunk+  deriving (Show)++data UrlPat = Chunk T.Text+            | Composed [UrlPat]+            | FuncChunk +                { chunkParamName :: T.Text+                , chunkFunc :: (T.Text -> Maybe ParsedChunk)+                , chunkType :: ChunkType }++instance Show UrlPat where+  show (Chunk a) = "(Chunk " ++ (T.unpack a) ++ ")"+  show (Composed a) = intercalate "/" $ fmap show a+  show (FuncChunk pn _ ct) = "(FuncChunk " ++ (T.unpack pn) ++ " | " ++ (show ct) ++ ")"++instance IsString UrlPat where+  fromString = Chunk . T.pack
+ src/Web/Wheb/Utils.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++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++lazyTextToSBS = TS.encodeUtf8 . T.toStrict+sbsToLazyText = T.fromStrict . TS.decodeUtf8+builderToText = T.decodeUtf8 . toLazyByteString++-- | Show and pack into 'Text'+spack :: Show a => a -> T.Text+spack = T.pack . show++-- | 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++----------------------- Instances ------------------------+instance WhebContent Builder where+  toResponse = responseBuilder++instance WhebContent T.Text where+  toResponse s hds = responseBuilder s hds . fromLazyByteString . T.encodeUtf8++instance WhebContent WhebFile where+  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 $ +            ("<h1>Error: " <> (T.pack $ show err) <> ".</h1>")++uhOh :: Response+uhOh = responseLBS status500 [("Content-Type", "text/html")]+      "Something went wrong on the server."
+ src/Web/Wheb/WhebT.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE RecordWildCards #-}++module Web.Wheb.WhebT+  (+  -- * ReaderT and StateT Functionality+  -- ** ReaderT+    getApp+  , getWithApp+  -- ** StateT+  , getHandlerState+  , putHandlerState+  , modifyHandlerState+  , modifyHandlerState'+  +  -- * Responses+  , setHeader+  , setRawHeader+  , html+  , text+  , file+  , builder+  +  -- * Settings+  , getSetting+  , getSetting'+  , getSetting''+  , getSettings+  +  -- * Routes+  , getRouteParams+  , getRouteParam+  , getRoute+  , getRoute'+  , getRawRoute+  +  -- * Request reading+  , getRequest+  , getRequestHeader+  , getWithRequest+  , getQueryParams+  , getPOSTParam+  , getPOSTParams+  , getRawPOST+  +  -- * Running Wheb+  , runWhebServer+  , runWhebServerT+  , debugHandler+  , debugHandlerT+  ) 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++-- * 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 duplicated from our options 'startingState'+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 ())++-- * 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+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 a setting or a default+getSetting'' :: (Monad m, Typeable a) => T.Text -> a -> WhebT g s m a+getSetting'' k d = liftM (fromMaybe d) (getSetting' k)++-- | 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 a+getRouteParam t = do+  p <- getRouteParam' t+  maybe (throwError RouteParamDoesNotExist) return p++-- | 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)+getRoute' n l = liftM buildRoute (getRawRoute n l)+    where buildRoute (Just (Route {..})) = generateUrl routeParser l+          buildRoute (Nothing)           = Left UrlNameNotFound++-- | Generate the raw route+getRawRoute :: Monad m => T.Text -> +             RouteParamList -> +             WhebT g s m (Maybe (Route g s m))+getRawRoute n l = WhebT $ liftM f ask  +    where findRoute (Route {..}) = fromMaybe False (fmap (==n) routeName)  +          f = ((find findRoute) . appRoutes . globalSettings)    ++-- * 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)++-- | 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++-- | 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 => 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++-- | Give content type and Blaze Builder+builder :: Monad m => T.Text -> Builder -> WhebHandlerT g s m+builder c b = do+    setHeader (T.pack "Content-Type") c +    return $ HandlerResponse status200 b+    +-- * Running a Wheb Application++-- | Running a Handler with a custom Transformer+debugHandlerT :: 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 = +    runIO $ runDebugHandler opts h baseData+    where baseData = HandlerData startingCtx r ([], []) [] opts++-- | Convenience wrapper for 'debugHandlerT' function in 'IO'+debugHandler :: WhebOptions g s IO -> +              WhebT g s IO a ->+              IO (Either WhebError a)+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 :: (m EResponse -> IO EResponse) ->+                  WhebOptions g s m ->+                  IO ()+runWhebServerT runIO opts@(WhebOptions {..}) = do+    putStrLn $ "Now running on port " ++ (show $ port)++    installHandler sigINT catchSig Nothing+    installHandler sigTERM catchSig Nothing++    forkIO $ runSettings rtSettings $+        gracefulExit $+        waiStack $ +        optsToApplication opts runIO++    loop+    waitForConnections+    putStrLn $ "Shutting down server..."+    sequence_ cleanupActions++  where catchSig = (Catch (atomically $ writeTVar shutdownTVar True))+        loop = do+          shutDown <- atomically $ readTVar shutdownTVar+          if shutDown then return () else (threadDelay 100000) >> loop+        gracefulExit app r = do+          isExit <- atomically $ readTVar shutdownTVar+          case isExit of+              False -> app r+              True  -> return $ responseLBS serviceUnavailable503 [] LBS.empty+        waitForConnections = do+          openConnections <- atomically $ readTVar activeConnections+          if (openConnections > 0)+            then waitForConnections+            else return ()+        port = fromMaybe 3000 $ +          (M.lookup (T.pack "port") runTimeSettings) >>= (\(MkVal m) -> cast m)+        rtSettings = warpSettings { W.settingsPort = port }++-- | Convenience wrapper for 'runWhebServerT' function in IO+runWhebServer :: (WhebOptions g s IO) -> IO ()+runWhebServer = runWhebServerT id
+ tests/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.QuickCheck+import TestRoutes (checkURL)+import System.Exit (exitFailure)++main :: IO ()+main = do+    putStrLn "Running route tests:"+    quickCheck checkURL