diff --git a/Web/Wheb.hs b/Web/Wheb.hs deleted file mode 100644 --- a/Web/Wheb.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/Cookie.hs b/Web/Wheb/Cookie.hs deleted file mode 100644 --- a/Web/Wheb/Cookie.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/InitM.hs b/Web/Wheb/InitM.hs deleted file mode 100644 --- a/Web/Wheb/InitM.hs +++ /dev/null @@ -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 } diff --git a/Web/Wheb/Internal.hs b/Web/Wheb/Internal.hs deleted file mode 100644 --- a/Web/Wheb/Internal.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/Plugins/Auth.hs b/Web/Wheb/Plugins/Auth.hs deleted file mode 100644 --- a/Web/Wheb/Plugins/Auth.hs +++ /dev/null @@ -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) diff --git a/Web/Wheb/Plugins/Debug/MemoryBackend.hs b/Web/Wheb/Plugins/Debug/MemoryBackend.hs deleted file mode 100644 --- a/Web/Wheb/Plugins/Debug/MemoryBackend.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/Plugins/Session.hs b/Web/Wheb/Plugins/Session.hs deleted file mode 100644 --- a/Web/Wheb/Plugins/Session.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/Routes.hs b/Web/Wheb/Routes.hs deleted file mode 100644 --- a/Web/Wheb/Routes.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/Types.hs b/Web/Wheb/Types.hs deleted file mode 100644 --- a/Web/Wheb/Types.hs +++ /dev/null @@ -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 diff --git a/Web/Wheb/Utils.hs b/Web/Wheb/Utils.hs deleted file mode 100644 --- a/Web/Wheb/Utils.hs +++ /dev/null @@ -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 $ - ("

Error: " <> (T.pack $ show err) <> ".

") - -uhOh :: Response -uhOh = responseLBS status500 [("Content-Type", "text/html")] - "Something went wrong on the server." diff --git a/Web/Wheb/WhebT.hs b/Web/Wheb/WhebT.hs deleted file mode 100644 --- a/Web/Wheb/WhebT.hs +++ /dev/null @@ -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 diff --git a/Wheb.cabal b/Wheb.cabal --- a/Wheb.cabal +++ b/Wheb.cabal @@ -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 + . + * + . + /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 "

About!

") + > 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 $ ("

Welcome to" <> appName <> - > "

You are visitor #" <> (pack $ show num) <> "

") + > "

You are visitor #" <> (spack num) <> "

") > > 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 diff --git a/src/Web/Wheb.hs b/src/Web/Wheb.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb.hs @@ -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 diff --git a/src/Web/Wheb/Cookie.hs b/src/Web/Wheb/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Cookie.hs @@ -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 diff --git a/src/Web/Wheb/InitM.hs b/src/Web/Wheb/InitM.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/InitM.hs @@ -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 ((), ()))) diff --git a/src/Web/Wheb/Internal.hs b/src/Web/Wheb/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Internal.hs @@ -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 diff --git a/src/Web/Wheb/Plugins/Auth.hs b/src/Web/Wheb/Plugins/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Plugins/Auth.hs @@ -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) diff --git a/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs b/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs @@ -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 diff --git a/src/Web/Wheb/Plugins/Session.hs b/src/Web/Wheb/Plugins/Session.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Plugins/Session.hs @@ -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 diff --git a/src/Web/Wheb/Routes.hs b/src/Web/Wheb/Routes.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Routes.hs @@ -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 diff --git a/src/Web/Wheb/Types.hs b/src/Web/Wheb/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Types.hs @@ -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 diff --git a/src/Web/Wheb/Utils.hs b/src/Web/Wheb/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Utils.hs @@ -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 $ + ("

Error: " <> (T.pack $ show err) <> ".

") + +uhOh :: Response +uhOh = responseLBS status500 [("Content-Type", "text/html")] + "Something went wrong on the server." diff --git a/src/Web/Wheb/WhebT.hs b/src/Web/Wheb/WhebT.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/WhebT.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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