diff --git a/Wheb.cabal b/Wheb.cabal --- a/Wheb.cabal +++ b/Wheb.cabal @@ -1,5 +1,5 @@ name: Wheb -version: 0.2.0.0 +version: 0.3.0.0 synopsis: The frictionless WAI Framework license: BSD3 license-file: LICENSE @@ -16,6 +16,8 @@ . * Minimal boilerplate to start your application. . + * Session, Auth and Cache interfaces are built in. Just drop in a backend. + . * Typesafe web-routes or named routes and URL generation. . * Easy to use for REST APIs @@ -41,20 +43,25 @@ . * Auth . + * Cache + . * . + * + . * . /Wheb in action:/ . + Use with language extensions /OverloadedStrings/ + . > import Web.Wheb - > import Data.Text.Lazy (pack) > > main :: IO () > main = do > opts <- genMinOpts $ do - > addGET "home" rootPat $ (text (pack "Hi!")) - > addGET "about" ("about" "something") $ html (pack "

About!

") + > addGET "home" rootPat $ text "Hi!" + > addGET "about" ("about" "something") $ html "

About!

" > runWhebServer opts . /Bigger example (Stateful.hs):/ @@ -72,7 +79,7 @@ > import Control.Concurrent.STM > import Control.Monad.IO.Class > import Data.Monoid - > import Data.Text.Lazy (Text, pack) + > import Data.Text.Lazy (Text) > import Web.Wheb > > data MyApp = MyApp Text (TVar Int) @@ -100,7 +107,7 @@ > opts <- generateOptions $ do > startingCounter <- liftIO $ newTVarIO 0 > addWhebMiddleware counterMw - > addGET (pack ".") rootPat $ homePage + > addGET "." rootPat $ homePage > return $ (MyApp "AwesomeApp" startingCounter, MyHandlerData 0) > runWhebServer opts @@ -111,7 +118,7 @@ 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 + 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.Cache, Web.Wheb.Plugins.Debug.MemoryBackend build-depends: base >= 4.7 && < 4.8, text >= 1.0 && < 1.2, @@ -140,7 +147,7 @@ test-suite Main type: exitcode-stdio-1.0 - build-depends: Wheb ==0.2.*, + build-depends: Wheb ==0.3.*, base ==4.7.*, HUnit >= 1.2 && < 2, QuickCheck >= 2.4, diff --git a/src/Web/Wheb.hs b/src/Web/Wheb.hs --- a/src/Web/Wheb.hs +++ b/src/Web/Wheb.hs @@ -34,6 +34,8 @@ , file , builder , redirect + , throwRedirect + -- *** Setting a header , setHeader , setRawHeader @@ -117,4 +119,4 @@ import Web.Wheb.Routes ((), compilePat, grabInt, grabText, pS, pT, rootPat) import Web.Wheb.Types (ChunkType(..), CSettings, WhebSocket, EResponse, HandlerData(..), HandlerResponse(..), InitM(..), InitOptions(..), InternalState(..), MethodMatch, MinHandler, MinOpts, MinWheb, PackedSite(..), ParsedChunk(..), Route(..), RouteParamList, SettingsValue(..), UrlBuildError(..), UrlParser(..), UrlPat(..), WhebContent(..), WhebError(..), WhebFile(..), WhebHandler, WhebHandlerT, WhebMiddleware, WhebOptions(..), WhebT(..)) import Web.Wheb.Utils (spack) -import Web.Wheb.WhebT (builder, runRawHandler, runRawHandlerT, file, redirect, getApp, getHandlerState, getPOSTParam, getPOSTParams, getQueryParams, getRawPOST, getRequest, getRequestHeader, getRoute, getRoute', getRouteParam, getRouteParams, getSetting, getSetting', getSetting'', getSettings, getWithApp, getWithRequest, html, modifyHandlerState, modifyHandlerState', putHandlerState, runWhebServer, runWhebServerT, setHeader, setRawHeader, text) +import Web.Wheb.WhebT (builder, runRawHandler, runRawHandlerT, file, redirect, throwRedirect, getApp, getHandlerState, getPOSTParam, getPOSTParams, getQueryParams, getRawPOST, getRequest, getRequestHeader, getRoute, getRoute', getRouteParam, getRouteParams, getSetting, getSetting', getSetting'', getSettings, getWithApp, getWithRequest, html, modifyHandlerState, modifyHandlerState', putHandlerState, runWhebServer, runWhebServerT, setHeader, setRawHeader, text) diff --git a/src/Web/Wheb/Cookie.hs b/src/Web/Wheb/Cookie.hs --- a/src/Web/Wheb/Cookie.hs +++ b/src/Web/Wheb/Cookie.hs @@ -7,18 +7,18 @@ , getCookies , removeCookie ) where - + +import Control.Monad (liftM) import qualified Blaze.ByteString.Builder as B (toByteString) -import Data.Maybe (fromMaybe) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T (empty, fromStrict, toStrict) +import Control.Monad.State (modify, MonadState(get)) +import Data.Text (Text) +import qualified Data.Text as TS (empty) +import qualified Data.Text.Encoding as TS (encodeUtf8) import Data.Time.Calendar (Day(ModifiedJulianDay)) import Data.Time.Clock (secondsToDiffTime, UTCTime(UTCTime)) -import Web.Cookie (CookiesText, def, parseCookiesText, renderSetCookie, - SetCookie(setCookieExpires, setCookieName, setCookieValue)) -import Web.Wheb.Types (WhebT) -import Web.Wheb.Utils (lazyTextToSBS) -import Web.Wheb.WhebT (getRequestHeader, setRawHeader) +import Web.Cookie (CookiesText, def, renderSetCookie, SetCookie(..)) +import Web.Wheb.Types +import Web.Wheb.WhebT (setRawHeader) getDefaultCookie :: Monad m => WhebT g s m SetCookie getDefaultCookie = return def -- Populate with settings... @@ -27,24 +27,23 @@ 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 +setCookie' k v sc = do + setRawHeader ("Set-Cookie", cookieText) + WhebT $ modify (\a -> a {curCookies = [(k,v)] ++ (curCookies a)}) + where cookie = sc { setCookieName = TS.encodeUtf8 k + , setCookieValue = TS.encodeUtf8 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 +getCookies = WhebT $ liftM (curCookies) get getCookie :: Monad m => Text -> WhebT g s m (Maybe Text) -getCookie k = getCookies >>= - (return . (fmap T.fromStrict) . (lookup (T.toStrict k))) +getCookie k = liftM (lookup k) getCookies 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 + setCookie' k TS.empty expiredCookie diff --git a/src/Web/Wheb/InitM.hs b/src/Web/Wheb/InitM.hs --- a/src/Web/Wheb/InitM.hs +++ b/src/Web/Wheb/InitM.hs @@ -35,8 +35,8 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Writer (liftM, MonadWriter(tell), Monoid(mempty), WriterT(runWriterT)) import qualified Data.Map as M (empty, fromList) -import qualified Data.Text.Lazy as T (lines, pack, splitOn, strip, Text, unpack) -import qualified Data.Text.Lazy.IO as T (readFile) +import qualified Data.Text as T (lines, pack, splitOn, strip, Text, unpack) +import qualified Data.Text.IO as T (readFile) import Data.Typeable (Typeable) import Network.HTTP.Types.Method (StdMethod(DELETE, GET, POST, PUT)) import Network.Wai (Middleware) @@ -134,7 +134,7 @@ , runTimeSettings = initSettings , warpSettings = warpsettings , startingCtx = g - , startingState = InternalState s M.empty + , startingState = InternalState s M.empty [] , waiStack = initWaiMw , whebMiddlewares = initWhebMw , defaultErrorHandler = defaultErr diff --git a/src/Web/Wheb/Internal.hs b/src/Web/Wheb/Internal.hs --- a/src/Web/Wheb/Internal.hs +++ b/src/Web/Wheb/Internal.hs @@ -2,24 +2,23 @@ module Web.Wheb.Internal where +import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Char8 as B +import Data.Maybe (fromMaybe) import Control.Monad (void) -import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Except (runExceptT) import Control.Monad.Reader (ReaderT(runReaderT)) import Control.Monad.State (evalStateT, StateT(runStateT)) import qualified Data.Map as M (toList) -import qualified Data.Text.Lazy as T (fromStrict, Text, toStrict, pack) import Network.HTTP.Types.Method (parseMethod, StdMethod(GET)) -import Network.Wai (Application, Request(pathInfo, requestMethod), Response) +import Network.Wai (Application, Request(..), Response) import Network.Wai.Parse (lbsBackEnd, parseRequestBody) import Network.Wai.Handler.WebSockets (websocketsOr) import qualified Network.WebSockets as W import Web.Wheb.Routes (findUrlMatch, findSiteMatch, findSocketMatch) -import Web.Wheb.Types (EResponse, HandlerData(HandlerData, postData, routeParams), - HandlerResponse(HandlerResponse), InternalState(..), - WhebContent(toResponse), WhebError(Error404), WhebHandlerT, - WhebMiddleware, WhebOptions(..), WhebT(runWhebT)) +import Web.Wheb.Types import Web.Wheb.Utils (uhOh) +import Web.Cookie (parseCookiesText) -- * Converting to WAI application @@ -37,21 +36,21 @@ Just (h, params) -> do c <- W.acceptRequest pc void $ runIO $ do - (mRes, st) <- runMiddlewares opts whebMiddlewares baseData - runDebugHandler (opts {startingState = st}) (h c) (baseData { routeParams = params }) + (mRes, st) <- runMiddlewares initOpts whebMiddlewares baseData + runDebugHandler (initOpts {startingState = st}) (h c) (baseData { routeParams = params }) Nothing -> W.rejectRequest pc (B.pack "No socket for path.") - handleMain r respond = do - pData <- parseRequestBody lbsBackEnd r + handleMain r' respond' = do + pData <- parseRequestBody lbsBackEnd r' res <- runIO $ do let mwData = baseData { postData = pData } - (mRes, st) <- runMiddlewares opts whebMiddlewares mwData + (mRes, st) <- runMiddlewares initOpts whebMiddlewares mwData case mRes of Just resp -> return $ Right resp Nothing -> do case (findSiteMatch appSites pathChunks) of Just h -> do - runWhebHandler opts h st mwData + runWhebHandler initOpts h st mwData Nothing -> do case (findUrlMatch stdMthd pathChunks appRoutes) of Just (h, params) -> do @@ -59,11 +58,13 @@ runWhebHandler opts h st hData Nothing -> return $ Left Error404 finished <- either handleError return res - respond finished + respond' finished baseData = HandlerData startingCtx r ([], []) [] opts - pathChunks = fmap T.fromStrict $ pathInfo r + parsedCookies = parseCookiesText $ (fromMaybe B.empty) $ (lookup $ CI.mk $ B.pack "Cookies") $ requestHeaders r + initOpts = opts {startingState = startingState {curCookies = parsedCookies}} + pathChunks = pathInfo r stdMthd = either (\_-> GET) id $ parseMethod $ requestMethod r - runErrorHandler eh = runWhebHandler opts eh startingState baseData + runErrorHandler eh = runWhebHandler initOpts eh startingState baseData handleError err = do errRes <- runIO $ runErrorHandler (defaultErrorHandler err) either (return . (const uhOh)) return errRes diff --git a/src/Web/Wheb/Plugins/Auth.hs b/src/Web/Wheb/Plugins/Auth.hs --- a/src/Web/Wheb/Plugins/Auth.hs +++ b/src/Web/Wheb/Plugins/Auth.hs @@ -36,7 +36,7 @@ import Control.Monad.Except (liftM, MonadError(throwError), MonadIO(..)) import Crypto.PasswordStore (makePassword, verifyPassword) import Data.Text.Encoding as ES (decodeUtf8, encodeUtf8) -import Data.Text.Lazy as T (fromStrict, pack, Text, toStrict) +import Data.Text as T (pack, Text) import Web.Wheb (getHandlerState, getWithApp, modifyHandlerState', WhebError(Error403), WhebHandlerT, WhebMiddleware, WhebT) import Web.Wheb.Plugins.Session (deleteSessionValue, getSessionValue', SessionApp, setSessionValue) @@ -140,9 +140,9 @@ 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 +makePwHash pw = liftM (ES.decodeUtf8) $ + liftIO $ makePassword (ES.encodeUtf8 $ pw) 14 verifyPw :: Text -> Text -> Bool -verifyPw pw hash = verifyPassword (ES.encodeUtf8 $ T.toStrict pw) - (ES.encodeUtf8 $ T.toStrict hash) +verifyPw pw hash = verifyPassword (ES.encodeUtf8 $ pw) + (ES.encodeUtf8 $ hash) diff --git a/src/Web/Wheb/Plugins/Cache.hs b/src/Web/Wheb/Plugins/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Web/Wheb/Plugins/Cache.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} + +module Web.Wheb.Plugins.Cache + ( CacheContainer (..) + , CacheApp (..) + , CacheBackend (..) + + , setCacheValue + , setCacheValue' + , getCacheValue + , getCacheValue' + , deleteCacheValue + ) where + +import Control.Monad (liftM) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.ByteString as BS (ByteString) +import Web.Wheb + +data CacheContainer = forall r. CacheBackend r => CacheContainer r + +class CacheApp a where + getCacheContainer :: a -> CacheContainer + +class CacheBackend c where + backendCachePut :: (CacheApp a, MonadIO m) => Text -> ByteString -> Integer -> c -> WhebT a b m () + backendCacheGet :: (CacheApp a, MonadIO m) => Text -> c -> WhebT a b m (Maybe ByteString) + backendCacheDelete :: (CacheApp a, MonadIO m) => Text -> c -> WhebT a b m () + +runWithContainer :: (CacheApp a, MonadIO m) => (forall r. CacheBackend r => r -> WhebT a s m b) -> WhebT a s m b +runWithContainer f = do + CacheContainer cacheStore <- getWithApp getCacheContainer + f cacheStore + +deleteCacheValue :: (CacheApp a, MonadIO m) => Text -> WhebT a b m () +deleteCacheValue key = runWithContainer $ backendCacheDelete key + +-- | Set a cache value with an expiration of an hour +setCacheValue :: (CacheApp a, MonadIO m) => Text -> ByteString -> WhebT a b m () +setCacheValue key content = setCacheValue' key content (60 * 60) + +-- | Set a cache value with expiration in seconds +setCacheValue' :: (CacheApp a, MonadIO m) => Text -> ByteString -> Integer -> WhebT a b m () +setCacheValue' key content expr = runWithContainer $ backendCachePut key content expr + +getCacheValue :: (CacheApp a, MonadIO m) => Text -> WhebT a b m (Maybe ByteString) +getCacheValue key = runWithContainer $ backendCacheGet key + +getCacheValue' :: (CacheApp a, MonadIO m) => ByteString -> Text -> WhebT a b m ByteString +getCacheValue' def key = liftM (fromMaybe def) (getCacheValue key) diff --git a/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs b/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs --- a/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs +++ b/src/Web/Wheb/Plugins/Debug/MemoryBackend.hs @@ -5,17 +5,32 @@ import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Map as M (alter, delete, empty, insert, lookup, Map, member, update) import Data.Maybe (fromMaybe) -import Data.Text.Lazy (Text) +import Data.Text (Text) +import Data.ByteString (ByteString) import Web.Wheb (InitM) -import Web.Wheb.Plugins.Auth (AuthBackend(..), AuthContainer(..), AuthError(..), AuthUser(AuthUser), - getUserSessionKey, makePwHash, PwHash, UserKey, verifyPw) -import Web.Wheb.Plugins.Session (deleteSessionValue, SessionBackend(..), SessionContainer(..)) +import Web.Wheb.Plugins.Auth +import Web.Wheb.Plugins.Cache +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) } +data CacheData = CacheData + { cacheStorage :: TVar (M.Map Text ByteString) } + +-- | In memory cache backend. Cache value +-- will not persist after server restart and will never clear old values. +instance CacheBackend CacheData where + backendCachePut key content _ (CacheData tv) = do + liftIO $ atomically $ modifyTVar tv (M.insert key content) + backendCacheGet key (CacheData tv) = do + curCache <- liftIO $ readTVarIO tv + return $ (M.lookup key curCache) + backendCacheDelete key (CacheData tv) = + liftIO $ atomically $ modifyTVar tv (M.delete key) + -- | In memory session backend. Session values -- will not persist after server restart. instance SessionBackend SessionData where @@ -68,3 +83,8 @@ initAuthMemory = do tv <- liftIO $ newTVarIO $ M.empty return $! AuthContainer $ UserData tv + +initCacheMemory :: InitM g s m CacheContainer +initCacheMemory = do + tv <- liftIO $ newTVarIO $ M.empty + return $! CacheContainer $ CacheData tv diff --git a/src/Web/Wheb/Plugins/Session.hs b/src/Web/Wheb/Plugins/Session.hs --- a/src/Web/Wheb/Plugins/Session.hs +++ b/src/Web/Wheb/Plugins/Session.hs @@ -19,9 +19,9 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (fromMaybe) -import Data.Text.Lazy (pack, Text) -import Data.Text.Lazy.Encoding as T (decodeUtf8) -import Data.UUID (toLazyASCIIBytes) +import Data.Text (pack, Text) +import Data.Text.Encoding as T (decodeUtf8) +import Data.UUID (toASCIIBytes) import Data.UUID.V4 (nextRandom) import Web.Wheb (getWithApp, WhebT) import Web.Wheb.Cookie (getCookie, setCookie) @@ -71,7 +71,7 @@ generateSessionKey :: (SessionApp a, MonadIO m) => WhebT a b m Text generateSessionKey = do - newKey <- liftM (T.decodeUtf8 . toLazyASCIIBytes) (liftIO nextRandom) + newKey <- liftM (T.decodeUtf8 . toASCIIBytes) (liftIO nextRandom) setCookie session_cookie_key newKey return newKey diff --git a/src/Web/Wheb/Routes.hs b/src/Web/Wheb/Routes.hs --- a/src/Web/Wheb/Routes.hs +++ b/src/Web/Wheb/Routes.hs @@ -24,20 +24,18 @@ ) where import Data.Monoid ((<>)) -import qualified Data.Text.Lazy as T (fromStrict, null, pack, Text, toStrict) -import Data.Text.Lazy.Read (decimal, Reader) +import qualified Data.Text as TS (null, pack, Text) +import qualified Data.Text.Encoding as TS (encodeUtf8) +import Data.Text.Read (decimal, Reader) import Data.Typeable (cast, Typeable) import Network.HTTP.Types.Method (StdMethod) import Network.HTTP.Types.URI (decodePathSegments, encodePathSegments) import Web.Routes (runSite) -import Web.Wheb.Types (ChunkType(..), ParsedChunk(..), Route(Route), RouteParamList, - UrlBuildError(NoParam, ParamTypeMismatch), UrlParser(UrlParser), - UrlPat(Chunk, Composed, FuncChunk), WhebHandlerT, SocketRoute(SocketRoute), - PackedSite(..), WhebSocket) -import Web.Wheb.Utils (builderToText, lazyTextToSBS, spack) +import Web.Wheb.Types +import Web.Wheb.Utils (builderToText, lazyTextToSBS, spacks, builderToStrictText) -- | Build a 'Route' from a 'UrlPat' -patRoute :: (Maybe T.Text) -> +patRoute :: (Maybe TS.Text) -> StdMethod -> UrlPat -> WhebHandlerT g s m -> @@ -51,7 +49,7 @@ -- | Represents root path @/@ rootPat :: UrlPat -rootPat = Chunk $ T.pack "" +rootPat = Chunk $ TS.pack "" -- | Allows for easier building of URL patterns -- This should be the primary URL constructor. @@ -65,39 +63,39 @@ a b = Composed [a, b] -- | Parses URL parameter and matches on 'Int' -grabInt :: T.Text -> UrlPat +grabInt :: TS.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 :: TS.Text -> UrlPat grabText key = FuncChunk key (Just . MkChunk) TextChunk -- | Constructors to use w/o OverloadedStrings -pT :: T.Text -> UrlPat +pT :: TS.Text -> UrlPat pT = Chunk pS :: String -> UrlPat -pS = pT . T.pack +pS = pT . TS.pack -- | Lookup and cast a URL parameter to its expected type if it exists. -getParam :: Typeable a => T.Text -> RouteParamList -> Maybe a +getParam :: Typeable a => TS.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 :: [TS.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 -> RouteParamList -> Either UrlBuildError TS.Text generateUrl (UrlParser _ f) = f -- | Sort through a list of routes to find a Handler and 'RouteParamList' findUrlMatch :: StdMethod -> - [T.Text] -> + [TS.Text] -> [Route g s m] -> Maybe (WhebHandlerT g s m, RouteParamList) findUrlMatch _ _ [] = Nothing @@ -108,7 +106,7 @@ Nothing -> findUrlMatch rmtd path rs -- | Sort through socket routes to find a match -findSocketMatch :: [T.Text] -> [SocketRoute g s m] -> Maybe (WhebSocket g s m, RouteParamList) +findSocketMatch :: [TS.Text] -> [SocketRoute g s m] -> Maybe (WhebSocket g s m, RouteParamList) findSocketMatch _ [] = Nothing findSocketMatch path ((SocketRoute (UrlParser f _) h):rs) = case f path of @@ -116,22 +114,22 @@ Nothing -> findSocketMatch path rs findSiteMatch :: [PackedSite g s m] -> - [T.Text] -> + [TS.Text] -> Maybe (WhebHandlerT g s m) findSiteMatch [] _ = Nothing findSiteMatch ((PackedSite t site):sites) cs = either (const (findSiteMatch sites cs)) Just $ - runSite (T.toStrict t) site (map T.toStrict cs) + runSite t site cs -- | 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 + Right t -> case (matchUrl (decodeUrl t) up) of Just params -> either (const False) (==t) (generateUrl up params) Nothing -> False - where decodeUrl = decodePathSegments . lazyTextToSBS + where decodeUrl = decodePathSegments . TS.encodeUtf8 -- | Implementation for a 'UrlParser' using pseudo-typed URL composition. -- Pattern will match path when the pattern is as long as the path, matching @@ -142,15 +140,15 @@ -- 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 :: [UrlPat] -> [TS.Text] -> Maybe RouteParamList +matchPat chunks [] = matchPat chunks [TS.pack ""] matchPat chunks t = parse t chunks [] where parse [] [] params = Just params - parse [] c params = Nothing - parse (u:[]) [] params | T.null u = Just params + parse [] _ params = Nothing + parse (u:[]) [] params | TS.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 + parse _ [] _ = Nothing + parse (u:us) ((Chunk c):cs) params | TS.null c = parse (u:us) cs params | u == c = parse us cs params | otherwise = Nothing parse (u:us) ((FuncChunk k f _):cs) params = do @@ -158,28 +156,28 @@ 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 :: [UrlPat] -> RouteParamList -> Either UrlBuildError TS.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 + build acc ((Chunk c):cs) | TS.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) + addSlashes [] = TS.pack "/" + addSlashes list = builderToStrictText $ + encodePathSegments list -showParam :: ChunkType -> T.Text -> RouteParamList -> Either UrlBuildError T.Text +showParam :: ChunkType -> TS.Text -> RouteParamList -> Either UrlBuildError TS.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) + IntChunk -> toEither $ fmap spacks (cast v :: Maybe Int) + TextChunk -> toEither (cast v :: Maybe TS.Text) Nothing -> Left NoParam where toEither v = case v of Just b -> Right b - Nothing -> Left $ ParamTypeMismatch k + Nothing -> Left $ ParamTypeMismatch $ k diff --git a/src/Web/Wheb/Types.hs b/src/Web/Wheb/Types.hs --- a/src/Web/Wheb/Types.hs +++ b/src/Web/Wheb/Types.hs @@ -17,6 +17,7 @@ import Data.Map as M (Map) import Data.String (IsString(..)) import qualified Data.Text.Lazy as T (pack, Text, unpack) +import qualified Data.Text as TS (pack, Text, unpack) import Data.Typeable (Typeable) import Network.HTTP.Types.Header (HeaderName, ResponseHeaders) import Network.HTTP.Types.Method (StdMethod) @@ -26,7 +27,7 @@ import Network.Wai.Parse (File, Param) import Network.WebSockets (Connection) import Web.Routes (Site(..)) - +import Web.Cookie (CookiesText) -- | WhebT g s m -- @@ -56,7 +57,7 @@ toResponse :: Status -> ResponseHeaders -> a -> Response -- | A Wheb response that represents a file. -data WhebFile = WhebFile T.Text +data WhebFile = WhebFile TS.Text data HandlerResponse = forall a . WhebContent a => HandlerResponse Status a @@ -71,15 +72,17 @@ -- | Our 'StateT' portion of 'WhebT' uses this. data InternalState s = InternalState { reqState :: s - , respHeaders :: M.Map HeaderName ByteString } + , respHeaders :: M.Map HeaderName ByteString + , curCookies :: CookiesText } data SettingsValue = forall a. (Typeable a) => MkVal a -data WhebError = Error500 String +data WhebError = Error500 T.Text | Error404 | Error403 + | ErrorStatus Status T.Text | RouteParamDoesNotExist - | URLError T.Text UrlBuildError + | URLError TS.Text UrlBuildError deriving (Show) -- | Monoid to use in InitM's WriterT @@ -121,7 +124,7 @@ type EResponse = Either WhebError Response -type CSettings = M.Map T.Text SettingsValue +type CSettings = M.Map TS.Text SettingsValue type WhebHandler g s = WhebT g s IO HandlerResponse type WhebHandlerT g s m = WhebT g s m HandlerResponse @@ -135,9 +138,9 @@ type MinOpts = WhebOptions () () IO -- * Routes -data PackedSite g s m = forall a . PackedSite T.Text (Site a (WhebHandlerT g s m)) +data PackedSite g s m = forall a . PackedSite TS.Text (Site a (WhebHandlerT g s m)) -type RouteParamList = [(T.Text, ParsedChunk)] +type RouteParamList = [(TS.Text, ParsedChunk)] type MethodMatch = StdMethod -> Bool data ParsedChunk = forall a. (Typeable a, Show a) => MkChunk a @@ -145,16 +148,16 @@ instance Show ParsedChunk where show (MkChunk a) = show a -data UrlBuildError = NoParam | ParamTypeMismatch T.Text | UrlNameNotFound +data UrlBuildError = NoParam | ParamTypeMismatch TS.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) } + { parseFunc :: ([TS.Text] -> Maybe RouteParamList) + , genFunc :: (RouteParamList -> Either UrlBuildError TS.Text) } data Route g s m = Route - { routeName :: (Maybe T.Text) + { routeName :: (Maybe TS.Text) , routeMethod :: MethodMatch , routeParser :: UrlParser , routeHandler :: (WhebHandlerT g s m) } @@ -167,17 +170,17 @@ data ChunkType = IntChunk | TextChunk deriving (Show) -data UrlPat = Chunk T.Text +data UrlPat = Chunk TS.Text | Composed [UrlPat] | FuncChunk - { chunkParamName :: T.Text - , chunkFunc :: (T.Text -> Maybe ParsedChunk) + { chunkParamName :: TS.Text + , chunkFunc :: (TS.Text -> Maybe ParsedChunk) , chunkType :: ChunkType } instance Show UrlPat where - show (Chunk a) = "(Chunk " ++ (T.unpack a) ++ ")" + show (Chunk a) = "(Chunk " ++ (TS.unpack a) ++ ")" show (Composed a) = intercalate "/" $ fmap show a - show (FuncChunk pn _ ct) = "(FuncChunk " ++ (T.unpack pn) ++ " | " ++ (show ct) ++ ")" + show (FuncChunk pn _ ct) = "(FuncChunk " ++ (TS.unpack pn) ++ " | " ++ (show ct) ++ ")" instance IsString UrlPat where - fromString = Chunk . T.pack + fromString = Chunk . TS.pack diff --git a/src/Web/Wheb/Utils.hs b/src/Web/Wheb/Utils.hs --- a/src/Web/Wheb/Utils.hs +++ b/src/Web/Wheb/Utils.hs @@ -2,24 +2,29 @@ module Web.Wheb.Utils where -import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString) +import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString, toByteString) import Data.IORef (atomicModifyIORef, newIORef, readIORef) import Data.Monoid ((<>), Monoid(mappend, mempty)) import qualified Data.Text.Encoding as TS (decodeUtf8, encodeUtf8) +import qualified Data.Text as TS (pack, unpack, Text) import qualified Data.Text.Lazy as T (fromStrict, pack, Text, toStrict) import qualified Data.Text.Lazy.Encoding as T (decodeUtf8, encodeUtf8) import Network.HTTP.Types.Status (status500) import Network.Wai (Response, responseBuilder, responseFile, responseLBS, responseToStream) -import Web.Wheb.Types (HandlerResponse(..), WhebContent(..), WhebError, WhebFile(..), WhebHandlerT) +import Web.Wheb.Types (HandlerResponse(..), WhebContent(..), WhebError(..), WhebFile(..), WhebHandlerT) lazyTextToSBS = TS.encodeUtf8 . T.toStrict sbsToLazyText = T.fromStrict . TS.decodeUtf8 builderToText = T.decodeUtf8 . toLazyByteString - --- | Show and pack into 'Text' +builderToStrictText = TS.decodeUtf8 . toByteString +-- | Show and pack into Lazy 'Text' spack :: Show a => a -> T.Text spack = T.pack . show +-- | Show and pack into Strict 'Text' +spacks :: Show a => a -> TS.Text +spacks = TS.pack . show + -- | See a 'HandlerResponse's as 'Text' showResponseBody :: HandlerResponse -> IO T.Text showResponseBody (HandlerResponse s r) = do @@ -42,10 +47,11 @@ toResponse s hds = responseBuilder s hds . fromLazyByteString . T.encodeUtf8 instance WhebContent WhebFile where - toResponse s hds (WhebFile fp) = responseFile s hds (show fp) Nothing + toResponse s hds (WhebFile fp) = responseFile s hds (TS.unpack fp) Nothing ----------------------- Some defaults ----------------------- defaultErr :: Monad m => WhebError -> WhebHandlerT g s m +defaultErr (ErrorStatus s t) = return $ HandlerResponse s t defaultErr err = return $ HandlerResponse status500 $ ("

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

") diff --git a/src/Web/Wheb/WhebT.hs b/src/Web/Wheb/WhebT.hs --- a/src/Web/Wheb/WhebT.hs +++ b/src/Web/Wheb/WhebT.hs @@ -20,6 +20,7 @@ , file , builder , redirect + , throwRedirect -- * Settings , getSetting @@ -53,7 +54,7 @@ import Blaze.ByteString.Builder (Builder) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM (atomically, readTVar, newTVarIO, writeTVar) -import Control.Monad.Error (liftM, MonadError(throwError), MonadIO, void) +import Control.Monad.Except (liftM, MonadError(throwError), MonadIO) import Control.Monad.Reader (MonadReader(ask)) import Control.Monad.State (modify, MonadState(get)) import qualified Data.ByteString.Lazy as LBS (ByteString, empty) @@ -61,7 +62,9 @@ import Data.List (find) import qualified Data.Map as M (insert, lookup) import Data.Maybe (fromMaybe) -import qualified Data.Text.Lazy as T (pack, empty, Text) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as T import Data.Typeable (cast, Typeable) import Network.HTTP.Types.Header (Header) import Network.HTTP.Types.Status (serviceUnavailable503, status200, status302) @@ -69,15 +72,10 @@ import Network.Wai (defaultRequest, Request(queryString, requestHeaders), responseLBS) import Network.Wai.Handler.Warp as W (runSettings, setPort) import Network.Wai.Parse (File, Param) -import System.Posix.Signals (Handler(Catch), installHandler, sigINT, sigTSTP, sigTERM) +import System.Posix.Signals (Handler(Catch), installHandler, sigINT, sigTERM) import Web.Wheb.Internal (optsToApplication, runDebugHandler) import Web.Wheb.Routes (generateUrl, getParam) -import Web.Wheb.Types (CSettings, EResponse, HandlerData(HandlerData, globalCtx, globalSettings, postData, request, routeParams), - HandlerResponse(HandlerResponse), InternalState(InternalState, reqState, respHeaders), - Route(..), RouteParamList, SettingsValue(..), - UrlBuildError(UrlNameNotFound), WhebError(RouteParamDoesNotExist, URLError), - WhebFile(WhebFile), WhebHandlerT, WhebOptions(..), WhebT(WhebT)) -import Web.Wheb.Utils (lazyTextToSBS, sbsToLazyText) +import Web.Wheb.Types -- * ReaderT and StateT Functionality @@ -114,17 +112,17 @@ -- * Settings -- | Help prevent monomorphism errors for simple settings. -getSetting :: Monad m => T.Text -> WhebT g s m (Maybe T.Text) +getSetting :: Monad m => TS.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' :: (Monad m, Typeable a) => TS.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'' :: (Monad m, Typeable a) => TS.Text -> a -> WhebT g s m a getSetting'' k d = liftM (fromMaybe d) (getSetting' k) -- | Get all settings. @@ -138,17 +136,17 @@ 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 :: (Typeable a, Monad m) => TS.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' :: (Typeable a, Monad m) => TS.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 :: Monad m => TS.Text -> RouteParamList -> WhebT g s m TS.Text getRoute name l = do res <- getRoute' name l case res of @@ -156,15 +154,15 @@ Left err -> throwError $ URLError name err -- | Generate a route from a name and param list. -getRoute' :: Monad m => T.Text -> +getRoute' :: Monad m => TS.Text -> RouteParamList -> - WhebT g s m (Either UrlBuildError T.Text) + WhebT g s m (Either UrlBuildError TS.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 -> +getRawRoute :: Monad m => TS.Text -> RouteParamList -> WhebT g s m (Maybe (Route g s m)) getRawRoute n _ = WhebT $ liftM f ask @@ -185,12 +183,12 @@ getRawPOST = WhebT $ liftM postData ask -- | Get POST params as 'Text' -getPOSTParams :: MonadIO m => WhebT g s m [(T.Text, T.Text)] +getPOSTParams :: MonadIO m => WhebT g s m [(TS.Text, TS.Text)] getPOSTParams = liftM (fmap f . fst) getRawPOST - where f (a, b) = (sbsToLazyText a, sbsToLazyText b) + where f (a, b) = (TS.decodeUtf8 a, TS.decodeUtf8 b) -- | Maybe get one param if it exists. -getPOSTParam :: MonadIO m => T.Text -> WhebT g s m (Maybe T.Text) +getPOSTParam :: MonadIO m => TS.Text -> WhebT g s m (Maybe TS.Text) getPOSTParam k = liftM (lookup k) getPOSTParams -- | Get params from URL (e.g. from '/foo/?q=4') @@ -198,10 +196,10 @@ getQueryParams = getWithRequest queryString -- | Get a request header -getRequestHeader :: Monad m => T.Text -> WhebT g s m (Maybe T.Text) +getRequestHeader :: Monad m => TS.Text -> WhebT g s m (Maybe TS.Text) getRequestHeader k = getRequest >>= f - where hk = mk $ lazyTextToSBS k - f = (return . (fmap sbsToLazyText) . (lookup hk) . requestHeaders) + where hk = mk $ TS.encodeUtf8 k + f = (return . (fmap TS.decodeUtf8) . (lookup hk) . requestHeaders) -- * Responses @@ -212,39 +210,45 @@ 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) +setHeader :: Monad m => TS.Text -> TS.Text -> WhebT g s m () +setHeader hn hc = setRawHeader (mk $ TS.encodeUtf8 hn, TS.encodeUtf8 hc) --- | Give filepath and content type to serve a file from disk. -file :: Monad m => T.Text -> T.Text -> WhebHandlerT g s m +-- | Give filepath and content type to serve a file via lazy text. +file :: Monad m => TS.Text -> TS.Text -> WhebHandlerT g s m file fp ct = do - setHeader (T.pack "Content-Type") (ct) + setHeader (TS.pack "Content-Type") (ct) return $ HandlerResponse status200 (WhebFile fp) --- | Return simple HTML from Text +-- | Return simple HTML from lazy Text html :: Monad m => T.Text -> WhebHandlerT g s m html c = do - setHeader (T.pack "Content-Type") (T.pack "text/html") + setHeader (TS.pack "Content-Type") (TS.pack "text/html") return $ HandlerResponse status200 c --- | Return simple Text +-- | Return simple lazy Text text :: Monad m => T.Text -> WhebHandlerT g s m text c = do - setHeader (T.pack "Content-Type") (T.pack "text/plain") + setHeader (TS.pack "Content-Type") (TS.pack "text/plain") return $ HandlerResponse status200 c -- | Give content type and Blaze Builder -builder :: Monad m => T.Text -> Builder -> WhebHandlerT g s m +builder :: Monad m => TS.Text -> Builder -> WhebHandlerT g s m builder c b = do - setHeader (T.pack "Content-Type") c + setHeader (TS.pack "Content-Type") c return $ HandlerResponse status200 b -- | Redirect to a given URL -redirect :: Monad m => T.Text -> WhebHandlerT g s m +redirect :: Monad m => TS.Text -> WhebHandlerT g s m redirect c = do - setHeader (T.pack "Location") c + setHeader (TS.pack "Location") c return $ HandlerResponse status302 T.empty +-- | Thow a redirect as an error +throwRedirect :: Monad m => TS.Text -> WhebHandlerT g s m +throwRedirect c = do + setHeader (TS.pack "Location") c + throwError $ ErrorStatus status302 T.empty + -- * Running a Wheb Application -- | Running a Handler with a custom Transformer @@ -275,23 +279,25 @@ installHandler sigINT catchSig Nothing installHandler sigTERM catchSig Nothing - installHandler sigTSTP (Catch (atomically $ writeTVar forceTVar True >> writeTVar shutdownTVar True)) Nothing forkIO $ runSettings rtSettings $ gracefulExit $ waiStack $ optsToApplication opts runIO - loop + let termSig = (Catch (atomically $ writeTVar forceTVar True >> writeTVar shutdownTVar True)) + installForceKill = installHandler sigTERM termSig Nothing >> installHandler sigINT termSig Nothing + + loop installForceKill putStrLn $ "Waiting for connections to close..." waitForConnections forceTVar putStrLn $ "Shutting down server..." sequence_ cleanupActions where catchSig = (Catch (atomically $ writeTVar shutdownTVar True)) - loop = do + loop terminate = do shutDown <- atomically $ readTVar shutdownTVar - if shutDown then return () else (threadDelay 100000) >> loop + if shutDown then terminate else (threadDelay 100000) >> loop terminate gracefulExit app r respond = do isExit <- atomically $ readTVar shutdownTVar case isExit of @@ -304,7 +310,7 @@ then return () else waitForConnections forceTVar port = fromMaybe 3000 $ - (M.lookup (T.pack "port") runTimeSettings) >>= (\(MkVal m) -> cast m) + (M.lookup (TS.pack "port") runTimeSettings) >>= (\(MkVal m) -> cast m) rtSettings = W.setPort port warpSettings -- | Convenience wrapper for 'runWhebServerT' function in IO