wai-session-redis (empty) → 0.1.0.0

raw patch · 6 files changed

+342/−0 lines, 6 filesdep +basedep +bytestringdep +cereal

Dependencies added: base, bytestring, cereal, data-default, hedis, hspec, http-types, vault, wai, wai-session, wai-session-redis, warp

Files

LICENSE +30/−0
README.md +12/−0
example/Main.hs +31/−0
src/Network/Wai/Session/Redis.hs +118/−0
test/Spec.hs +64/−0
wai-session-redis.cabal +87/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright t4ccer++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 t4ccer 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.

+ README.md view

@@ -0,0 +1,12 @@+# wai-session-redis+Provides Redis based session store for [Network.Wai.Session](https://hackage.haskell.org/package/wai-session)  +For example usage view [example/Main.hs](https://github.com/t4ccer/wai-session-redis/tree/main/example/Main.hs)++## Tests+To run tests `wai-session-redis` must have access to running `redis` instance.+### Using docker+```bash+docker run --name redis-session-tests -p 6379:6379 -d redis+stack test+docker rm -f redis-session-tests+```

+ example/Main.hs view

@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.ByteString.Char8     as SBS+import           Data.Default+import           Data.String               (fromString)+import qualified Data.Vault.Lazy           as Vault+import           Network.HTTP.Types+import           Network.Wai+import           Network.Wai.Handler.Warp+import           Network.Wai.Session       (Session, withSession)++import           Network.Wai.Session.Redis++app :: Vault.Key (Session IO String String) -> Application+app session env = (>>=) $ do+  u <- sessionLookup "u"+  sessionInsert "u" insertThis+  return $ responseLBS ok200 [] $ maybe (fromString "Nothing") fromString u+    where+      insertThis = show $ pathInfo env+      Just (sessionLookup, sessionInsert) = Vault.lookup session (vault env)++main :: IO ()+main = do+  let s = def+  session <- Vault.newKey+  store <- dbStore s+  run 1337 $ withSession store (fromString "SESSION") def session $ app session+

+ src/Network/Wai/Session/Redis.hs view

@@ -0,0 +1,118 @@+{-# LANGUAGE BlockArguments    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++-- |+-- Module: Network.Wai.Session.Redis+-- Copyright: (c) 2021, t4ccer+-- License: BSD3+-- Stability: experimental+-- Portability: portable+--+-- Simple Redis backed wai-session backend. This module allows you to store+-- session data of wai-sessions in a Redis database.+module Network.Wai.Session.Redis+  ( dbStore+  , clearSession+  , SessionSettings(..)+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.ByteString        (ByteString)+import           Data.Default+import           Data.Either+import           Data.Serialize         (Serialize, decode, encode)+import           Database.Redis         hiding (decode)+import           Network.Wai.Session++-- | Settings to control session store+data SessionSettings = SessionSettings+  { redisConnectionInfo :: ConnectInfo+  , expiratinTime       :: Integer+  -- ^ Session expiration time in seconds+  }++instance Default SessionSettings where+  def = SessionSettings+    { redisConnectionInfo = defaultConnectInfo+    , expiratinTime       = 60*60*24*7 -- One week+    }++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left _)  = Nothing+eitherToMaybe (Right a) = Just a++connectAndRunRedis :: MonadIO m => ConnectInfo -> Redis b -> m b+connectAndRunRedis ci cmd = liftIO do+  conn <- connect ci+  res  <- runRedis conn cmd+  disconnect conn+  return res++createSession :: MonadIO m => SessionSettings -> m ByteString+createSession SessionSettings{..} = liftIO do+  sesId <- genSessionId+  connectAndRunRedis redisConnectionInfo $ do+    hset sesId "" ""+    expire sesId expiratinTime+  return sesId++isSesIdValid :: MonadIO m => SessionSettings -> ByteString -> m Bool+isSesIdValid SessionSettings{..} sesId = liftIO do+  res <- connectAndRunRedis redisConnectionInfo $ do+    exists sesId+  return $ fromRight False res++insertIntoSession :: MonadIO m => SessionSettings+  -> ByteString -- ^ Sessionn id+  -> ByteString -- ^ Key+  -> ByteString -- ^ Value+  -> m ()+insertIntoSession SessionSettings{..} sesId key value = do+  connectAndRunRedis redisConnectionInfo $ do+    hset sesId key value+    expire sesId expiratinTime+  return ()++lookupFromSession :: MonadIO m => SessionSettings+  -> ByteString -- ^ Session id+  -> ByteString -- ^ Key+  -> m (Maybe ByteString)+lookupFromSession SessionSettings{..} sesId key = do+  v <- connectAndRunRedis redisConnectionInfo $ do+    v <- hget sesId key+    expire sesId expiratinTime+    return v+  return $ join $ eitherToMaybe v++-- | Invalidate session id+clearSession :: MonadIO m => SessionSettings+  -> ByteString -- ^ Session id+  -> m ()+clearSession SessionSettings{..} sessionId = do+  connectAndRunRedis redisConnectionInfo $ do+    del [sessionId]+  return ()++-- | Create new redis backend wai session store+dbStore :: (MonadIO m1, MonadIO m2, Eq k, Serialize k, Serialize v) => SessionSettings -> m2 (SessionStore m1 k v)+dbStore s = do+  return $ dbStore' s++dbStore' :: (MonadIO m1, MonadIO m2, Eq k, Serialize k, Serialize v, Monad m2) => SessionSettings -> Maybe ByteString -> m2 (Session m1 k v, m2 ByteString)+dbStore' s (Just sesId) = do+  isValid <- isSesIdValid s sesId+  if isValid+    then return (mkSessionFromSesId s sesId, return sesId)+    else dbStore' s Nothing+dbStore' s Nothing = do+  sesId <- createSession s+  return (mkSessionFromSesId s sesId, return sesId)++mkSessionFromSesId :: (MonadIO m1, Eq k, Serialize k, Serialize v) => SessionSettings -> ByteString -> Session m1 k v+mkSessionFromSesId s sesId = (mkLookup, mkInsert)+  where+    mkLookup k = liftIO $ fmap (join . fmap (eitherToMaybe . decode)) $ lookupFromSession s sesId (encode k)+    mkInsert k v = liftIO $ insertIntoSession s sesId (encode k) (encode v)+

+ test/Spec.hs view

@@ -0,0 +1,64 @@+-- Adapted from https://github.com/hce/postgresql-session/blob/master/test/Spec.hs++{-# LANGUAGE OverloadedStrings #-}+module Main where++import           Control.Concurrent+import qualified Data.ByteString           as B+import           Data.Default+import           Test.Hspec++import           Network.Wai.Session.Redis++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "Network.Wai.Session.Redis" $ it "handles sessions" $ do+    store <- dbStore testSettings++    -- new session+    ((lookupSess1, insertSess1), mknewsessid) <- store Nothing+    sessid <- mknewsessid++    -- insert+    insertSess1 ("foo" :: B.ByteString) ("foo" :: B.ByteString)+    lookupSess1 "foo" `shouldReturn` Just "foo"++    -- update+    insertSess1 ("foo" :: B.ByteString) ("bar" :: B.ByteString)+    lookupSess1 "foo" `shouldReturn` Just "bar"++    -- non-existing key+    lookupSess1 "bar" `shouldReturn` Nothing++    -- existing session+    ((lookupSess2, insertSess2), mknewsessid) <- store $ Just sessid+    newsessid <- mknewsessid++    lookupSess2 "foo" `shouldReturn` Just "bar"++    newsessid `shouldBe` sessid++    -- invalid session+    let invalidsessid = "foobar"+    ((lookupSess3, insertSess3), mknewsessid) <- store $ Just invalidsessid+    newsessid2 <- mknewsessid++    newsessid2 `shouldNotBe` newsessid+    newsessid2 `shouldNotBe` invalidsessid++    lookupSess3 "foo" `shouldReturn` Nothing++    -- re-accessing session+    ((lookupSess4, insertSess4), mknewsessid) <- store $ Just sessid+    lookupSess4 "foo" `shouldReturn` Just "bar"++    -- purged session+    threadDelay 2000000+    ((lookupSess5, insertSess5), mknewsessid) <- store $ Just sessid+    lookupSess5 "foo" `shouldReturn` Nothing++testSettings :: SessionSettings+testSettings = def {expiratinTime = 1}+

+ wai-session-redis.cabal view

@@ -0,0 +1,87 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 95001b72a04fd4250644f116fc3194bf3d3428b8a8078183501dba42e3ca9b8d++name:           wai-session-redis+version:        0.1.0.0+synopsis:       Simple Redis backed wai-session backend.+description:    Simple Redis backed wai-session backend. This module allows you to store session data of wai-sessions in a Redis database.+category:       Web+homepage:       https://github.com/t4ccer/wai-session-redis#readme+bug-reports:    https://github.com/t4ccer/wai-session-redis/issues+author:         t4ccer+maintainer:     t4ccer@gmail.com+copyright:      (c) 2021 t4ccer+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/t4ccer/wai-session-redis++library+  exposed-modules:+      Network.Wai.Session.Redis+  other-modules:+      Paths_wai_session_redis+  hs-source-dirs:+      src+  build-depends:+      base >=4.10.0 && <5+    , bytestring >=0.10 && <0.11+    , cereal >=0.5.8 && <0.5.9+    , data-default >=0.7 && <0.8+    , hedis >=0.14 && <0.15+    , vault >=0.3.1 && <0.3.2+    , wai >=3.2 && <3.3+    , wai-session >=0.3.3 && <0.3.4+  default-language: Haskell2010++executable wai-session-redis-example-exe+  main-is: Main.hs+  other-modules:+      Paths_wai_session_redis+  hs-source-dirs:+      example+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.10.0 && <5+    , bytestring >=0.10 && <0.11+    , cereal >=0.5.8 && <0.5.9+    , data-default >=0.7 && <0.8+    , hedis >=0.14 && <0.15+    , http-types <0.13+    , vault >=0.3.1 && <0.3.2+    , wai >=3.2 && <3.3+    , wai-session >=0.3.3 && <0.3.4+    , wai-session-redis+    , warp <3.3.15+  default-language: Haskell2010++test-suite wai-session-redis-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_wai_session_redis+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.10.0 && <5+    , bytestring >=0.10 && <0.11+    , cereal >=0.5.8 && <0.5.9+    , data-default >=0.7 && <0.8+    , hedis >=0.14 && <0.15+    , hspec <2.8+    , vault >=0.3.1 && <0.3.2+    , wai >=3.2 && <3.3+    , wai-session >=0.3.3 && <0.3.4+    , wai-session-redis+  default-language: Haskell2010