packages feed

wai-session-hasql (empty) → 1.0.0.0

raw patch · 7 files changed

+613/−0 lines, 7 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, cookie, hasql, hasql-pool, hspec, http-types, mmzk-typeid, pqi-native, text, time, uuid, vault, wai, wai-session, wai-session-hasql, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for wai-session-hasql++## 1.0.0.0 -- 2026-09-15++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Haoxiang Zhao+++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 the copyright holder nor the names of its+      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+HOLDER 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,21 @@+# wai-session-hasql++A [wai-session](https://hackage.haskell.org/package/wai-session) store that using PostgreSQL as backend, and [hasql](https://hackage.haskell.org/package/hasql) as db connector.++It supports both single hasql connection and hasql pool connection.++Basic usage, see `example/Main.hs` for a complete example. You will need to replace the connection string with your own PostgreSQL connection string in the example and tests files.++```haskell+main :: IO ()+main = do+  -- Create a vault key+  k <- newKey :: IO (Key (Network.Wai.Session.Session IO T.Text Aeson.Value))+  -- Init Hasql connection pool+  pool <- P.acquire adapter (settings [size 10, staticConnectionSettings (connectionString "postgres://dbadmin:P%40ssw0rd@localhost:5432/appdb")])+  s <- hasqlStore (SessionSetting (HasqlPool pool) True (60 * 60 * 24) False)+  -- Create the wai-session middleware by using withSession function+  let sm = withSession s (B8.pack "hello") defaultSetCookie k+      asess = sm $ app k+  run 3000 asess+```
+ example/Main.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Aeson qualified as Aeson+import Data.ByteString.Char8 qualified as B8+import Data.ByteString.Lazy.Char8 (pack)+import Data.Text qualified as T+import Data.Vault.Lazy (Key, newKey)+import Data.Vault.Lazy qualified as Vault+import Hasql.Connection.Settings (connectionString)+import Hasql.Pool qualified as P+import Hasql.Pool.Config+  ( settings,+    size,+    staticConnectionSettings,+  )+import Network.HTTP.Types (hContentType, status200)+import Network.Wai+  ( Application,+    Request (pathInfo, vault),+    responseLBS,+  )+import Network.Wai.Handler.Warp (run)+import Network.Wai.Session (Session, withSession)+import Network.Wai.Session.Hasql+  ( HasqlConnectionType (HasqlPool),+    SessionSetting (SessionSetting),+    hasqlStore,+  )+import Pqi.Native (adapter)+import Web.Cookie (defaultSetCookie)++-- When you access any page, it will create session and insert some key-values into this session+app :: Key (Network.Wai.Session.Session IO T.Text Aeson.Value) -> Application+app key req respond = do+  putStrLn "Hello world"+  sessionInsert (T.pack "hello") (Aeson.toJSON insertThis)+  sessionInsert (T.pack "world") "Whoareyou"+  mValue <- sessionLookup (T.pack "hello")+  print mValue+  respond $ responseLBS status200 [(hContentType, B8.pack "text/html")] (pack "<h1>Hello world</h1>")+  where+    insertThis = show $ pathInfo req+    Just (sessionLookup, sessionInsert) = Vault.lookup key (vault req)++main :: IO ()+main = do+  -- Create a vault key+  k <- newKey :: IO (Key (Network.Wai.Session.Session IO T.Text Aeson.Value))+  -- Init Hasql connection pool+  pool <- P.acquire adapter (settings [size 10, staticConnectionSettings (connectionString "postgres://dbadmin:P%40ssw0rd@localhost:5432/appdb")])+  s <- hasqlStore (SessionSetting (HasqlPool pool) True (60 * 60 * 24) False)+  -- Create the wai-session middleware by using withSession function+  let sm = withSession s (B8.pack "hello") defaultSetCookie k+      asess = sm $ app k+  putStrLn "Server is running on port 3000"+  run 3000 asess
+ src/Network/Wai/Session/Hasql.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Session.Hasql+  ( hasqlStore,+    SessionSetting (..),+    HasqlConnectionType (..),+    HasqlSessionException (..),+    ToSessionKey (..),+    Session (..),+    genNewSession,+    purgeExpiredSessions,+  )+where++import Control.Exception (Exception, throwIO)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Aeson+  ( FromJSON,+    Result (Error, Success),+    ToJSON (toJSON),+    Value (Object),+    fromJSON,+    object,+  )+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Char8 qualified as B8+import Data.Functor.Contravariant ((>$<))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.Text qualified as T+import Data.Time (UTCTime, getCurrentTime)+import Data.TypeID.V7 (genTypeID, getUUID)+import Data.UUID (UUID, fromASCIIBytes, toASCIIBytes)+import Hasql.Connection qualified as C+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Errors (SessionError)+import Hasql.Pool qualified as P+import Hasql.Session qualified as S+import Hasql.Statement qualified as St+import Network.Wai.Session (SessionStore)++-- | Wrapper for the hasql exceptions when using pool or single connection+data HasqlSessionException = HasqlSessionPoolException P.UsageError | HasqlSessionConnException SessionError deriving (Show)++instance Exception HasqlSessionException++-- | Wrapper for different kinds of Hasql connection type+data HasqlConnectionType = HasqlConnection C.Connection | HasqlPool P.Pool++-- | Settings for Hasql Session Store+data SessionSetting = SessionSetting+  { -- | Hasql connection, pool or single connection.+    ssHasqlConn :: HasqlConnectionType,+    -- | Whether init database table, if True, will init the table with the default schema. @eg. True@+    ssInitDB :: Bool,+    -- | Valid period for a session, unit: seconds. @eg. 60 * 60 * 24@+    ssExpiresAfter :: Int64,+    -- | Whether to store newly generated sessions without any KV data in the database. This means that if a new session is generated without any Key-Value pair inserted, it will not be written to the database to prevent bots or something from trying to spam your website. @eg. False@+    ssWriteEmptySession :: Bool+  }++-- | Haskell representation for 'wai_pg_sessions' table schema+data Session = Session+  { -- | Session ID in UUID(v7) format+    sSessId :: UUID,+    -- | KV store by using JSON+    sData :: Value,+    -- | Timestamp when this session was created+    sCreatedAt :: UTCTime,+    -- | Timestamp when this session was updated+    sUpdatedAt :: UTCTime,+    -- | Timestamp when this session will expire+    sExpiresAt :: UTCTime+  }+  deriving (Show, Eq)++-- | Class for adapting the 'k' parameter in @'Network.Wai.Session.SessionStore' m k v@, this package uses 'Data.Text.Text' as the type of key. If you want to use your own key type with the getter or setter function in 'Network.Wai.Session.SessionStore', you need to implement this class for your own type+class ToSessionKey k where+  toSessionKey :: k -> T.Text++instance ToSessionKey T.Text where+  toSessionKey = id++instance ToSessionKey String where+  toSessionKey = T.pack++-- | A generic Hasql session executor+executeQuery :: HasqlConnectionType -> S.Session a -> IO a+executeQuery (HasqlConnection c) s =+  C.use c s >>= \case+    Left err -> throwIO (HasqlSessionConnException err)+    Right v -> return v+executeQuery (HasqlPool p) s =+  P.use p s >>= \case+    Left err -> throwIO (HasqlSessionPoolException err)+    Right v -> return v++-- | A Hasql decoder to decode one session row to Session data+sessionDecoder :: D.Row Session+sessionDecoder =+  Session+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)++-- | A sql statement to init the table+createSessionTableQ :: T.Text+createSessionTableQ =+  "create table if not exists wai_pg_sessions ("+    <> "sess_id uuid primary key,"+    <> "data jsonb default '{}' not null,"+    <> "created_at timestamptz default current_timestamp not null,"+    <> "updated_at timestamptz default current_timestamp not null,"+    <> "expires_at timestamptz default (current_timestamp + interval '30 days') not null"+    <> ")"++-- | A sql statement to query the session row by using sess_id.+selectSessionQ :: St.Statement UUID (Maybe Session)+selectSessionQ = St.preparable sql encoder decoder+  where+    sql = "select * from wai_pg_sessions where sess_id = $1"+    encoder = E.param (E.nonNullable E.uuid)+    decoder = D.rowMaybe sessionDecoder++-- | A sql statement to insert a new session record or update if exists+upsertSessionQ :: St.Statement (Session, Int64) ()+upsertSessionQ = St.preparable sql encoder decoder+  where+    sql = "insert into wai_pg_sessions (sess_id, data, expires_at) values ($1, $2, current_timestamp + make_interval(secs => $4)) on conflict (sess_id) do update set data = $2, updated_at = $3"+    encoder = (sSessId . fst >$< E.param (E.nonNullable E.uuid)) <> (sData . fst >$< E.param (E.nonNullable E.jsonb)) <> (sUpdatedAt . fst >$< E.param (E.nonNullable E.timestamptz)) <> (snd >$< E.param (E.nonNullable E.int8))+    decoder = D.noResult++-- | A session store that using postgresql as db backend, Hasql as db connector+hasqlStore :: forall m k v. (MonadIO m, FromJSON v, ToJSON v, ToSessionKey k) => SessionSetting -> IO (SessionStore m k v)+hasqlStore ss =+  executeQuery (ssHasqlConn ss) (S.script createSessionTableQ) >> return (hasqlStore' ss)++-- | Backend for Hasql session store.+hasqlStore' :: (MonadIO m, FromJSON v, ToJSON v, ToSessionKey k) => SessionSetting -> SessionStore m k v+hasqlStore' ss k = do+  let mUUID = k >>= fromASCIIBytes+  gotSession <- case mUUID of+    (Just x) -> do+      res <- executeQuery (ssHasqlConn ss) (S.statement x selectSessionQ)+      maybe genNewSession return res+    Nothing -> genNewSession+  ref <- newIORef (gotSession, ssWriteEmptySession ss)+  return ((reader ref, writer ref), final ref ss)++-- | A helper function to convert aeson 'Data.Aeson.Value' to aeson 'Data.Aeson.KeyMap.KeyMap'+valueToKeyMap :: Value -> KM.KeyMap Value+valueToKeyMap (Object km) = km+valueToKeyMap _ = KM.empty++-- | The main getter function in @'Network.Wai.Session.Session' m k v@+reader :: (MonadIO m, FromJSON a, ToSessionKey k) => IORef (Session, Bool) -> k -> m (Maybe a)+reader r k = do+  (sess, _) <- liftIO $ readIORef r+  let aesonKey = K.fromText (toSessionKey k)+      dataKM = valueToKeyMap (sData sess)+  case KM.lookup aesonKey dataKM of+    Nothing -> return Nothing+    Just vv -> case fromJSON vv of+      Success v -> return $ Just v+      Error _ -> return Nothing++-- | The main setter function in @'Network.Wai.Session.Session' m k v@+writer :: (MonadIO m, ToJSON a, ToSessionKey k) => IORef (Session, Bool) -> k -> a -> m ()+writer r k v = do+  (sess, _) <- liftIO $ readIORef r+  currentTime <- liftIO getCurrentTime+  let aesonKey = K.fromText (toSessionKey k)+      dataKM = valueToKeyMap (sData sess)+      newData = Object (KM.insert aesonKey (toJSON v) dataKM)+  let newSession = sess {sData = newData, sUpdatedAt = currentTime}+  liftIO $ writeIORef r (newSession, True)++final :: IORef (Session, Bool) -> SessionSetting -> IO B8.ByteString+final r ss = do+  (sess, isModified) <- readIORef r+  case isModified of+    True -> do+      executeQuery (ssHasqlConn ss) (S.statement (sess, ssExpiresAfter ss) upsertSessionQ)+      return $ toASCIIBytes (sSessId sess)+    False -> return $ toASCIIBytes (sSessId sess)++-- | A helper function used to generate a new Session, using "Data.TypeID.V7" as UUIDv7 generator+genNewSession :: IO Session+genNewSession = genTypeID "sess" >>= (\u -> getCurrentTime >>= \now -> return (Session u (object []) now now now)) . getUUID++-- | A helper function used to purge all expired sessions+purgeExpiredSessions :: SessionSetting -> IO ()+purgeExpiredSessions ss = do+  executeQuery (ssHasqlConn ss) (S.script sql)+  where+    sql :: T.Text+    sql = "delete from wai_pg_sessions where expires_at < now()"
+ test/Main.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main (main) where++import Data.Aeson qualified as Aeson+import Data.Text qualified as T+import GHC.Conc (threadDelay)+import Hasql.Connection.Settings (connectionString)+import Hasql.Pool (Pool, acquire)+import Hasql.Pool.Config+  ( settings,+    size,+    staticConnectionSettings,+  )+import Network.Wai.Session.Hasql+  ( HasqlConnectionType (HasqlPool),+    SessionSetting (SessionSetting),+    hasqlStore,+    purgeExpiredSessions,+  )+import Pqi.Native (adapter)+import Test.Hspec+  ( Spec,+    describe,+    hspec,+    it,+    shouldBe,+    shouldContain,+    shouldNotBe,+  )++main :: IO ()+main = hspec spec++testConnection :: IO Pool+testConnection = acquire adapter (settings [size 10, staticConnectionSettings (connectionString "postgres://dbadmin:P%40ssw0rd@localhost:5432/appdb")])++spec :: Spec+spec = describe "Hasql Store Package Functionality" $ do+  it "Should be able to create new session" $ do+    c <- testConnection+    s <- hasqlStore @IO @T.Text @Aeson.Value (SessionSetting (HasqlPool c) True (60 * 60 * 24) True)++    (_, final) <- s Nothing+    sess_id <- final+    shouldContain (show sess_id) "-"++  it "Should not write empty session to database when ssWriteEmptySession is False" $ do+    c <- testConnection+    s <- hasqlStore @IO @T.Text @Aeson.Value (SessionSetting (HasqlPool c) True (60 * 60 * 24) False)++    (_, final) <- s Nothing+    sess_id <- final+    (_, final2) <- s (Just sess_id)+    sess_id2 <- final2+    shouldNotBe sess_id sess_id2++  it "Should be able to insert and lookup KV pair for new session" $ do+    c <- testConnection+    s <- hasqlStore @IO @T.Text @Aeson.Value (SessionSetting (HasqlPool c) True (60 * 60 * 24) True)++    ((reader, writer), final) <- s Nothing+    writer "test_key" "test_value"+    _ <- final+    mV <- reader "test_key"+    shouldContain (show mV) "test_value"++  it "Should be able to lookup a existing session from incoming cookie" $ do+    c <- testConnection+    s <- hasqlStore @IO @T.Text @Aeson.Value (SessionSetting (HasqlPool c) True (60 * 60 * 24) True)++    ((_, writer), final) <- s Nothing+    sess_id <- final+    writer "test_key_2" "test_value_2"+    _ <- final+    ((reader2, _), final2) <- s (Just sess_id)+    sess_id2 <- final2+    shouldBe sess_id sess_id2+    mV2 <- reader2 "test_key_2"+    shouldContain (show mV2) "test_value_2"++  it "Should be able to update a existing KV in one session" $ do+    c <- testConnection+    s <- hasqlStore @IO @T.Text @Aeson.Value (SessionSetting (HasqlPool c) True (60 * 60 * 24) True)++    ((reader, writer), final) <- s Nothing+    writer "test_key_3" "test_value_3"+    _ <- final+    mV <- reader "test_key_3"+    shouldContain (show mV) "test_value_3"+    writer "test_key_3" "test_value_3 spooky"+    _ <- final+    mV2 <- reader "test_key_3"+    shouldContain (show mV2) "test_value_3 spooky"++  it "The helper function purgeExpiredSessions should be able to purge expired sessions" $ do+    c <- testConnection+    -- Change the expiration time to 10s+    let ss = SessionSetting (HasqlPool c) True 10 True+    s <- hasqlStore @IO @T.Text @Aeson.Value ss++    ((reader, writer), final) <- s Nothing+    writer "test_key_4" "test_value_4"+    sess_id <- final+    mV <- reader "test_key_4"+    shouldContain (show mV) "test_value_4"+    threadDelay 11000000+    purgeExpiredSessions ss+    ((reader2, _), _) <- s (Just sess_id)+    mV2 <- reader2 "test_key_4"+    shouldBe mV2 Nothing
+ wai-session-hasql.cabal view
@@ -0,0 +1,182 @@+cabal-version:      3.0+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'wai-session-hasql' generated by+-- 'cabal init'. For further documentation, see:+--   http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name:               wai-session-hasql++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version:            1.0.0.0++-- A short (one-line) description of the package.+synopsis:           A wai-session store using Hasql and PostgreSQL++-- A longer description of the package.+description:        Provides PostgreSQL as wai-session store, and using Hasql as the PostgreSQL connector. It supports both single Hasql connection and Hasql pool connection.++-- The license under which the package is released.+license:            BSD-3-Clause++-- The file containing the license text.+license-file:       LICENSE++-- The package author(s).+author:             Haoxiang Zhao++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer:         haoxiangz201@gmail.com++homepage:           https://github.com/Block81838/WAI-Session-Hasql++bug-reports:        https://github.com/Block81838/WAI-Session-Hasql/issues++tested-with:        ghc == 9.12.2++-- A copyright notice.+-- copyright:+category:           Web+build-type:         Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files:+    CHANGELOG.md+    README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++flag build-example+     description:     Build the example executable+     default:         False+     manual:          True++common extensions+    default-language: GHC2021++common ghc-options+    ghc-options: -Wall -Widentities++common rts-options+    ghc-options: -rtsopts -threaded "-with-rtsopts=-N"++library+    -- Common language extensions+    import:           extensions++    -- Common compiler warnings and optimisations+    import:           ghc-options++    -- Modules exported by the library.+    exposed-modules:  Network.Wai.Session.Hasql++    -- Modules included in this library but not exported.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:++    -- Other library packages from which modules are imported.+    build-depends:    base >=4.16.0.0 && <5,+                      hasql ^>=2.0,+                      hasql-pool ^>=1.5,+                      bytestring >= 0.10 && < 0.13,+                      text >= 1.2 && < 3,+                      time >= 1.9 && < 1.17,+                      uuid ^>=1.3,+                      mmzk-typeid ^>=0.7,+                      wai-session ^>=0.3,+                      aeson >=2.0 && <2.4++    -- Directories containing source files.+    hs-source-dirs:   src++    -- Base language which the package is written in.+    default-language: Haskell2010++executable wai-session-hasql-example+    import:           extensions++    import:           ghc-options++    import:           rts-options++    if !flag(build-example)+       buildable:     False+    else+       buildable:     True++    main-is:          Main.hs++    build-depends:    base >=4.16.0.0 && <5,+                      wai-session-hasql,+                      wai ^>=3.2,+                      text,+                      cookie ^>=0.5,+                      wai-session ^>=0.3,+                      warp ^>=3.4,+                      bytestring,+                      http-types ^>=0.12,+                      vault ^>=0.3,+                      hasql,+                      hasql-pool,+                      pqi-native ^>=1.0,+                      aeson++    hs-source-dirs:   example++test-suite wai-session-hasql-test+    -- Common language extensions+    import:           extensions++    -- Common compiler warnings and optimisations+    import:           ghc-options++    -- Common RTS options+    import:           rts-options++    -- Base language which the package is written in.+    default-language: Haskell2010++    -- Modules included in this executable, other than Main.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:++    -- The interface type and version of the test suite.+    type:             exitcode-stdio-1.0++    -- Directories containing source files.+    hs-source-dirs:   test++    -- The entrypoint to the test suite.+    main-is:          Main.hs++    -- Test dependencies.+    build-depends:    base >=4.16.0.0 && <5,+                      wai-session-hasql,+                      hspec,+                      hasql,+                      hasql-pool,+                      pqi-native,+                      text,+                      aeson+++source-repository head+    type:             git+    location:         https://github.com/Block81838/WAI-Session-Hasql.git