packages feed

Wheb (empty) → 0.0.1.0

raw patch · 14 files changed

+1060/−0 lines, 14 filesdep +basedep +blaze-builderdep +bytestringsetup-changed

Dependencies added: base, blaze-builder, bytestring, case-insensitive, conduit, containers, cookie, data-default, http-types, mtl, pwstore-fast, stm, text, time, transformers, uuid, wai, wai-extra, warp

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Kyle Hanson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Kyle Hanson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Wheb.hs view
@@ -0,0 +1,8 @@+module Web.Wheb (module All) where++import Web.Wheb.Internal as All+import Web.Wheb.Utils as All+import Web.Wheb.WhebT as All+import Web.Wheb.InitM as All+import Web.Wheb.Types as All+import Web.Wheb.Routes as All
+ Web/Wheb/Cookie.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Wheb.Cookie+  ( setCookie+  , setCookie'+  , getCookie+  , getCookies+  , removeCookie+  ) where++import Data.Maybe (fromMaybe)+import Data.Text.Lazy (Text)+import Data.Time.Calendar+import Data.Time.Clock+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Blaze.ByteString.Builder as B++import Web.Cookie++import Web.Wheb+import Web.Wheb.Types++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 = (getHeader "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 view
@@ -0,0 +1,67 @@+{-# LANGUAGE RecordWildCards #-}++module Web.Wheb.InitM 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++rGET :: (Maybe T.Text) -> UrlPat -> WhebHandlerT g s m -> Route g s m+rGET n p = Route n (==GET) (compilePat p)++rPOST :: (Maybe T.Text) -> UrlPat -> WhebHandlerT g s m -> Route g s m+rPOST n p = Route n (==POST) (compilePat p)++addGET :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m ()+addGET n p h = addRoute $ rGET (Just n) p h++addPOST :: T.Text -> UrlPat -> WhebHandlerT g s m -> InitM g s m ()+addPOST n p h = addRoute $ rPOST (Just n) p h++addWAIMiddleware :: Middleware -> InitM g s m ()+addWAIMiddleware m = InitM $ tell $ mempty { initWaiMw = m }++addWhebMiddleware :: WhebMiddleware g s m -> InitM g s m ()+addWhebMiddleware m = InitM $ tell $ mempty { initWhebMw = [m] }++catchAllRoutes :: WhebHandlerT g s m -> InitM g s m ()+catchAllRoutes h = addRoute $ Route Nothing (const True) parser h+        where parser = UrlParser (const (Just [])) (const (Right $ T.pack "/*"))++addRoute :: Route g s m -> InitM g s m ()+addRoute r = addRoutes [r]++addRoutes :: [Route g s m] -> InitM g s m ()+addRoutes rs = InitM $ tell $ mempty { initRoutes = rs }++-- | Help prevent monomorphism errors for simple settings.+addSetting :: T.Text -> T.Text -> InitM g s m ()+addSetting = addSetting'++addSetting' :: Typeable a => T.Text -> a -> InitM g s m ()+addSetting' k v = addSettings $ M.fromList [(k, MkVal v)]++addSettings :: CSettings -> InitM g s m ()+addSettings settings = InitM $ tell $ mempty { initSettings = settings }+++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 view
@@ -0,0 +1,103 @@+{-# 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++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+                          +                          +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+          +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+                          +runWhebHandler :: (Default s, Monad m) =>+                    WhebOptions g s m ->+                    WhebHandlerT g s m ->+                    InternalState s ->+                    HandlerData g s m ->+                    m EResponse+runWhebHandler opts@(WhebOptions {..}) handler st hd = do+  (resp, InternalState {..}) <- flip runStateT st $ do+            flip runReaderT hd $+              runErrorT $+              runWhebT handler+  return $ fmap (convertResponse respHeaders) resp +  where convertResponse hds (HandlerResponse status resp) =+                          toResponse status (M.toList hds) resp+
+ Web/Wheb/Plugins/Auth.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++module Web.Wheb.Plugins.Auth +  ( AuthUser (..)+  , AuthContainer (..)+  , AuthApp (..)+  , AuthState (..)+  , AuthBackend (..)+  , AuthError (..)+  +  , UserKey+  , Password+  , PwHash+  +  , authMiddleware+  , login+  , logout+  , register+  , getCurrentUser+  , queryCurrentUser+  , loginRequired+  , makePwHash+  , verifyPw+  ) where++import Control.Applicative ((<*>))+import Control.Monad (void, liftM)+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+++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++class SessionApp a => AuthApp a where+  getAuthContainer :: a -> AuthContainer++class AuthState a where+  getAuthUser    :: a -> PossibleUser +  modifyAuthUser :: (PossibleUser -> PossibleUser) -> a -> a++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++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))++authMiddleware :: (AuthApp a, AuthState b, MonadIO m) => WhebMiddleware a b m+authMiddleware = do+    cur <- queryCurrentUser+    authSetUser cur+    return Nothing++getUserSessionKey :: (AuthApp a, MonadIO m) => WhebT a b m Text+getUserSessionKey = return $ T.pack "user-id" -- later read from settings.++register :: (AuthApp a, MonadIO m) => UserKey -> Password -> WhebT a b m (Either AuthError AuthUser)+register un pw = runWithContainer $ backendRegister un pw++login :: (AuthApp a, AuthState b, MonadIO m) => UserKey -> Password -> WhebT a b m (Either AuthError AuthUser)+login un pw = do+  loginResult <- (runWithContainer $ backendLogin un pw)+  case loginResult of+      Right au@(AuthUser userKey) -> do+          sessionKey <- getUserSessionKey+          deleteSessionValue sessionKey+          setSessionValue sessionKey userKey+          authSetUser (Just au)+      _ -> return ()+  return loginResult++logout :: (AuthApp a, AuthState b, MonadIO m) => WhebT a b m ()+logout = (runWithContainer backendLogout) >> (authSetUser Nothing)++getCurrentUser :: (AuthState b, MonadIO m) => WhebT a b m (Maybe AuthUser)+getCurrentUser = liftM getAuthUser getReqState++queryCurrentUser :: (AuthApp a, MonadIO m) => WhebT a b m (Maybe AuthUser)+queryCurrentUser = getUserSessionKey >>= +                 getSessionValue' (T.pack "") >>=+                 (\uid -> runWithContainer $ backendGetUser uid)++loginRequired :: WhebT a b m () -> WhebT a b m ()+loginRequired action = action++makePwHash :: MonadIO m => Password -> WhebT a b m PwHash+makePwHash pw = liftM (T.fromStrict . ES.decodeUtf8) $ +                        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 view
@@ -0,0 +1,69 @@+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)+                +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 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+    +-- | Initial pass on abstract plugin for Sessions.+--   Possibly add support for Typable to ease typecasting.++import Control.Monad.IO.Class+import Control.Monad (liftM)+import Data.Maybe+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++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 view
@@ -0,0 +1,111 @@+module Web.Wheb.Routes 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++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+                                        +matchUrl :: [T.Text] -> UrlParser -> Maybe RouteParamList+matchUrl url (UrlParser f _) = f url++generateUrl :: UrlParser -> RouteParamList -> Either UrlBuildError T.Text+generateUrl (UrlParser _ f) = f++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++--------- Url Patterns ------------+-- | Constructors to use w/o OverloadedStrings+pT :: T.Text -> UrlPat+pT = Chunk++pS :: String -> UrlPat+pS = pT . T.pack++-- | Represents root (/)+rootPat :: UrlPat+rootPat = Composed [] ++grabText :: T.Text -> UrlPat+grabText key = FuncChunk key (Just . MkChunk) TextChunk++grabInt :: T.Text -> UrlPat+grabInt key = FuncChunk key f IntChunk+  where rInt = decimal :: Reader Int+        f = ((either (const Nothing) (Just . MkChunk . fst)) . rInt)++-- | Allows for easier building of URL patterns+--   This should be the primary URL constructor.+(</>) :: UrlPat -> UrlPat -> UrlPat+(Composed a) </> (Composed b) = Composed (a ++ b)+a </> (Composed b) = Composed (a:b)+(Composed a) </> b = Composed (a ++ [b])+a </> b = Composed [a, b]+    +-- | Implementation for a UrlParser using pseudo-typed URL composition.+--   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 f t):cs) = +              case (showParam t k params) of+                      (Right  v)  -> build (acc <> [v]) cs+                      (Left err)  -> Left err+          slash = (T.pack "/")+          addSlashes list = slash <> (T.intercalate slash list) <> slash++compilePat :: UrlPat -> UrlParser+compilePat (Composed a) = UrlParser (matchPat a) (buildPat a)+compilePat a = UrlParser (matchPat [a]) (buildPat [a])++showParam :: ChunkType -> T.Text -> RouteParamList -> Either UrlBuildError T.Text+showParam chunkType k l = +    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 view
@@ -0,0 +1,135 @@+{-# LANGUAGE ExistentialQuantification   #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+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)++class WhebContent a where+  toResponse :: Status -> ResponseHeaders -> a -> Response++data HandlerResponse = forall a . WhebContent a => HandlerResponse Status a+data WhebFile = WhebFile FilePath+type EResponse = Either WhebError Response+data SettingsValue = forall a. (Typeable a) => MkVal a+type CSettings = M.Map T.Text SettingsValue+data WhebError = Error500 String +                  | Error404 +                  | URLError T.Text UrlBuildError+  deriving (Show)++instance Error WhebError where +    strMsg = Error500++data HandlerData g s m = +  HandlerData { globalCtx      :: g+              , request        :: Request+              , postData       :: ([Param], [File LBS.ByteString])+              , routeParams    :: RouteParamList+              , globalSettings :: WhebOptions g s m }++data InternalState s =+  InternalState { reqState     :: s+                , respHeaders  :: M.Map HeaderName ByteString } ++instance Default s => Default (InternalState s) where+  def = InternalState def def++data InitOptions g s m =+  InitOptions { initRoutes      :: [ Route g s m ]+              , initSettings    :: CSettings+              , initWaiMw       :: Middleware+              , initWhebMw   :: [ WhebMiddleware g s m ] }++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 }++instance Monoid (InitOptions g s m) where+  mappend (InitOptions a1 b1 c1 d1) (InitOptions a2 b2 c2 d2) = +      InitOptions (a1 <> a2) (b1 <> b2) (c2 . c1) (d1 <> d2)+  mempty = InitOptions mempty mempty id mempty++newtype InitM g s m a = InitM { runInitM :: WriterT (InitOptions g s m) IO a}+  deriving (Functor, Applicative, Monad, MonadIO)++-- | WhebT g s m+--   g -> The global confirgured context (Read-only data shared between threads)+--   s -> State initailized at the start of each request using Default+--   m -> Monad we are transforming+newtype WhebT g s m a = WhebT +  { runWhebT :: ErrorT WhebError +                  (ReaderT (HandlerData g s m) (StateT (InternalState s) m)) a +  } deriving ( Functor, Applicative, Monad, MonadIO )++instance MonadTrans (WhebT g s) where+  lift = WhebT . lift . lift . lift++instance (Monad m) => MonadError WhebError (WhebT g s m) where+    throwError = WhebT . throwError+    catchError (WhebT m) f = WhebT  (catchError m (runWhebT . f))++type MinWheb a = WhebT () () IO a+type MinOpts = WhebOptions () () IO+type WhebHandler g s      = WhebT g s IO HandlerResponse+type WhebHandlerT g s m   = WhebT g s m HandlerResponse+type WhebMiddleware g s m = WhebT g s m (Maybe HandlerResponse)+----------------- Routes -----------------++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 +            | FuncChunk T.Text (T.Text -> Maybe ParsedChunk) ChunkType+            | Composed [UrlPat]++instance IsString UrlPat where+  fromString = Chunk . T.pack
+ Web/Wheb/Utils.hs view
@@ -0,0 +1,46 @@+{-# 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++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 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 view
@@ -0,0 +1,162 @@+{-# LANGUAGE RecordWildCards #-}++module Web.Wheb.WhebT 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++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++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 ())++-- | 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++getSettings :: Monad m => WhebT g s m CSettings+getSettings = WhebT $ liftM (runTimeSettings . globalSettings) ask++getRouteParams :: Monad m => WhebT g s m RouteParamList+getRouteParams = WhebT $ liftM routeParams ask++getRouteParam :: (Typeable a, Monad m) => T.Text -> WhebT g s m (Maybe a)+getRouteParam t = liftM (getParam t) getRouteParams++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)++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++getRequest :: Monad m => WhebT g s m Request+getRequest = WhebT $ liftM request ask++getWithRequest :: Monad m => (Request -> a) -> WhebT g s m a+getWithRequest = flip liftM getRequest++getRawPOST :: MonadIO m => WhebT g s m ([Param], [File LBS.ByteString])+getRawPOST = WhebT $ liftM postData ask++getPOSTParams :: MonadIO m => WhebT g s m [(T.Text, T.Text)]+getPOSTParams = liftM (fmap f . fst) getRawPOST+  where f (a, b) = (sbsToLazyText a, sbsToLazyText b)++getPostParam :: MonadIO m => T.Text -> WhebT g s m (Maybe T.Text)+getPostParam k = liftM (lookup k) getPOSTParams ++getQueryParams :: Monad m => WhebT g s m Query+getQueryParams = getWithRequest queryString++getHeader :: Monad m => T.Text -> WhebT g s m (Maybe T.Text)+getHeader k = getRequest >>= f+  where hk = mk $ lazyTextToSBS k+        f = (return . (fmap sbsToLazyText) . (lookup hk) . requestHeaders)++setRawHeader :: Monad m => Header -> WhebT g s m ()+setRawHeader (hn, hc) = WhebT $ modify insertHeader +    where insertHeader is@(InternalState {..}) = +            is { respHeaders = M.insert hn hc respHeaders }++setHeader :: Monad m => T.Text -> T.Text -> WhebT g s m ()+setHeader hn hc = setRawHeader (mk $ lazyTextToSBS hn, lazyTextToSBS hc)++-- | Give filepath and content type to serve a file from disk.+file :: Monad m => FilePath -> T.Text -> WhebHandlerT g s m+file fp ct = do+    setHeader (T.pack "Content-Type") (ct) +    return $ HandlerResponse status200 (WhebFile fp)+    +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+    +text :: Monad m => T.Text -> WhebHandlerT g s m+text c = do+    setHeader (T.pack "Content-Type") (T.pack "text/plain") +    return $ HandlerResponse status200 c++----------------------- Running the application -----------------------+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++debugHandlerIO :: (Default s) => WhebOptions g s IO -> +              WhebT g s IO a ->+              IO (Either WhebError a)+debugHandlerIO opts h = debugHandlerT opts id defaultRequest h++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++runWhebServer :: (Default s) => +                 (WhebOptions g s IO) ->+                 IO ()+runWhebServer = runWhebServerT id
+ Wheb.cabal view
@@ -0,0 +1,57 @@+-- Initial Wheb.cabal generated by cabal init.  For further documentation, +-- see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                Wheb++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.0.1.0++-- A short (one-line) description of the package.+synopsis:            The easy Haskell WAI Framework++-- A longer description of the package.+-- description:         ++-- URL for the project homepage or repository.+homepage:            https://github.com/hansonkd/Wheb-Framework++-- The license under which the package is released.+license:             BSD3++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Kyle Hanson++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          hanooter@gmail.com++-- A copyright notice.+-- copyright:           ++category:            Web++build-type:          Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.8+++library+  -- Modules exported by the library.+  exposed-modules:     Web.Wheb, Web.Wheb.Cookie, Web.Wheb.InitM, Web.Wheb.Internal, Web.Wheb.Routes, Web.Wheb.Types, Web.Wheb.Utils, Web.Wheb.WhebT, Web.Wheb.Plugins.Auth, Web.Wheb.Plugins.Session, Web.Wheb.Plugins.Debug.MemoryBackend+  +  -- Modules included in this library but not exported.+  -- other-modules:       +  +  -- Other library packages from which modules are imported.+  build-depends:       base ==4.6.*, text ==0.11.*, transformers ==0.3.*, data-default ==0.5.*, wai-extra ==2.0.*, time ==1.4.*, bytestring ==0.10.*, blaze-builder ==0.3.*, cookie ==0.4.*, mtl ==2.1.*, containers ==0.5.*, wai ==2.0.*, http-types ==0.8.*, warp ==2.0.*, conduit ==1.0.*, case-insensitive ==1.0.*, pwstore-fast ==2.4.*, uuid ==1.3.*, stm ==2.4.*+