wheb-redis (empty) → 0.0.1.0

raw patch · 4 files changed

+255/−0 lines, 4 filesdep +Whebdep +basedep +bytestringsetup-changed

Dependencies added: Wheb, base, bytestring, hedis, mtl, text

Files

LICENSE +30/−0
Setup.hs +2/−0
src/Web/Wheb/Plugins/Redis.hs +128/−0
wheb-redis.cabal +95/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Kyle Hanson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Kyle Hanson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Web/Wheb/Plugins/Redis.hs view

@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-}++module Web.Wheb.Plugins.Redis (+      runRedis+    , initRedis+    , initRedisCache+    , RedisApp (..)+    , RedisCacheApp (..)+    , RedisContainer+    , RedisCacheContainer+    , module Database.Redis+    ) where+import Control.Monad (void, liftM)+import Data.Monoid ((<>))+import Data.ByteString+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Database.Redis hiding (runRedis)+import qualified Database.Redis as R+import Web.Wheb+import Web.Wheb.Plugins.Cache+import Web.Wheb.Plugins.Auth+import Web.Wheb.Plugins.Session+++sessionPrefix = T.pack "session"+userPrefix = T.pack "user"++-- | A container to use as a DB+data RedisContainer = RedisContainer Connection++-- | A seperate instance for cache+data RedisCacheContainer = RedisCacheContainer Connection++class RedisApp a where+  getRedisContainer :: a -> RedisContainer++instance RedisApp a => SessionApp a where+  getSessionContainer = SessionContainer . getRedisContainer++instance RedisApp a => AuthApp a where+  getAuthContainer = AuthContainer . getRedisContainer++class RedisCacheApp a where+  getRedisCacheContainer :: a -> RedisCacheContainer++instance RedisCacheApp a => CacheApp a where+  getCacheContainer = CacheContainer . getRedisCacheContainer+  +instance CacheBackend RedisCacheContainer where+  backendCachePut key content expr con = do+    mvoid $ runWithCacheContainer con $ setex (T.encodeUtf8 key) expr content+  backendCacheGet key con = do+      e <- runWithCacheContainer con $ get (T.encodeUtf8 key)+      return $ either (const Nothing) id e+  backendCacheDelete key con = do+      mvoid $ runWithCacheContainer con $ del [(T.encodeUtf8 key)]++instance SessionBackend RedisContainer where+  backendSessionPut sessId key content mc = do+    mvoid $ runWithContainer mc $ do+      hset (makeKey sessionPrefix sessId) (T.encodeUtf8 key) (T.encodeUtf8 content)+  backendSessionGet sessId key mc =  do+    runWithContainer mc $ do+      e <- hget (makeKey sessionPrefix sessId) (T.encodeUtf8 key)+      return $ either (const Nothing) (fmap T.decodeUtf8) e+  backendSessionDelete sessId key mc = do+    mvoid $ runWithContainer mc $+      hdel (makeKey sessionPrefix sessId) [T.encodeUtf8 key]+  backendSessionClear sessId mc = do+    mvoid $ runWithContainer mc $ do+      let sessk = (makeKey sessionPrefix sessId)+      ek <- hkeys sessk+      either (const $ return ()) (mvoid . hdel sessk) ek++instance AuthBackend RedisContainer where+  backendGetUser name mc = do+    runWithContainer mc $ do+      n <- get (makeKey userPrefix name)+      return $ either (const Nothing) (const $ Just $ AuthUser name) n+  backendLogin name pw mc =  do+    passCheck <- runWithContainer mc $ do+      n <- get (makeKey userPrefix name)+      return $ either (const Nothing) (fmap (verifyPw pw . T.decodeUtf8)) n+    case passCheck of+        Just True  -> return (Right $ AuthUser $ name)+        Just False -> return (Left InvalidPassword)+        Nothing    -> return (Left UserDoesNotExist)+  backendRegister user@(AuthUser name) pw mc =  do+    pwHash <- makePwHash pw+    runWithContainer mc $ do+      n <- get (makeKey userPrefix name)+      case n of+        Right Nothing -> do+          set (makeKey userPrefix name) (T.encodeUtf8 pwHash)+          return (Right $ user)+        _ -> return (Left DuplicateUsername)+  backendLogout _ =  getUserSessionKey >>= deleteSessionValue++makeKey :: T.Text -> T.Text -> ByteString+makeKey a b = T.encodeUtf8 $ a <> (T.pack ":") <> b++mvoid :: Monad m => m a -> m ()+mvoid a = a >> return ()++runWithCacheContainer :: MonadIO m => RedisCacheContainer -> Redis a -> WhebT g s m a+runWithCacheContainer (RedisCacheContainer con) r = liftIO $ R.runRedis con r++runWithContainer :: MonadIO m => RedisContainer -> Redis a -> WhebT g s m a+runWithContainer (RedisContainer con) r = liftIO $ R.runRedis con r++-- | Run a Redis command inside of WhebT+runRedis :: (RedisApp g, MonadIO m) => Redis a -> WhebT g s m a+runRedis r =  getWithApp getRedisContainer >>= flip runWithContainer r++-- | Initialize Redis.+initRedis :: MonadIO m => ConnectInfo -> InitM g s m RedisContainer+initRedis info = do+  conn <- liftIO $ connect info+  return $ RedisContainer conn++-- | Initialize a container for using redis as a cache. You will probably have a different+--  DB and settings for your data and cache so this is broken out.+initRedisCache :: MonadIO m => ConnectInfo -> InitM g s m RedisCacheContainer+initRedisCache info = do+  conn <- liftIO $ connect info+  return $ RedisCacheContainer conn

+ wheb-redis.cabal view

@@ -0,0 +1,95 @@++name:                wheb-redis+version:             0.0.1.0+synopsis:            Redis connection for Wheb++-- A longer description of the package.+-- description:         ++-- URL for the project homepage or repository.+homepage:            https://github.com/hansonkd/Wheb-Framework++-- The license under which the package is released.+license:             BSD3++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Kyle++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          me@khanson.io++-- A copyright notice.+-- copyright:           ++category:            Web++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++description:+  Implements basic functionality for:+  .+  * <http://hackage.haskell.org/package/hedis Hedis>+  .+  * <http://hackage.haskell.org/package/Wheb Wheb>+  .+  Gives instances of Auth, Session and Cache backends for Wheb.+  .+  /In action:/+  .+  Use with language extensions /OverloadedStrings/+  .+  >  import Web.Wheb+  >  import Web.Wheb.Plugins.Redis+  >  +  >  data MyCtx = MyCtx RedisContainer+  >  +  >  instance RedisApp MyCtx where+  >    getRedisContainer (MyCtx rc) = rc+  >  +  >  main :: IO ()+  >  main = do+  >    opts <- generateOptions $ do+  >        r <- initRedis defaultConnectInfo+  >        addGET "home" rootPat ((runRedis $ get "hello") >>= (text . spack))+  >        return (MyCtx r, ())+  >   +  >    runRawHandler opts $ do+  >        runRedis $ set "hello" "world"+  >   +  >    runWhebServer opts++library+  -- Modules exported by the library.+  exposed-modules:     Web.Wheb.Plugins.Redis+  +  -- Modules included in this library but not exported.+  -- other-modules:       +  +  -- LANGUAGE extensions used by modules in this package.+  other-extensions:    OverloadedStrings+  +  -- Other library packages from which modules are imported.+  build-depends:       base >=4.7 && <4.8, +                       mtl >=2.2 && <2.3, +                       Wheb >=0.3 && <0.4, +                       text >=1.1 && <1.2,+                       bytestring >=0.10 && <0.11,+                       hedis >=0.6 && <0.7+  +  -- Directories containing source files.+  hs-source-dirs: src   +  +  -- Base language which the package is written in.+  default-language:    Haskell2010+