v 0.4 add missing Session functions

.github/workflows/haskell.yml

@@ -16,7 +16,7 @@ jobs:
  fail-fast: false
  matrix:
  os: [ubuntu-latest]
- stack-resolver: ['nightly-2023-06-17', 'lts-20.24']
+ stack-resolver: ['lts-20.24']
  steps:
  - name: git checkout
  uses: actions/checkout@v3

CHANGELOG.md

@@ -8,4 +8,6 @@ and this project adheres to the
 
 ## Unreleased
 
-## 0.1.0.0 - YYYY-MM-DD
+## 0.4.0.0
+
+Add Session.tokensToList and Session.newTokens

ms-graph-api.cabal

@@ -1,5 +1,5 @@
 name: ms-graph-api
-version: 0.3.0.0
+version: 0.4.0.0
 synopsis: Microsoft Graph API
 description: Bindings to the Microsoft Graph API
 homepage: https://github.com/unfoldml/ms-graph-api

src/Network/OAuth2/Session.hs

@@ -12,9 +12,11 @@ module Network.OAuth2.Session (
  , replyEndpoint
  -- * In-memory user session
  , Tokens
+ , newTokens
  , UserSub
  , lookupUser
  , expireUser
+ , tokensToList
  -- * Scotty misc
  , Scotty
  , Action
@@ -33,7 +35,7 @@ import Data.Aeson
 -- bytestring
 import qualified Data.ByteString.Lazy.Char8 as BSL
 -- containers
-import qualified Data.Map as M (Map, insert, lookup, alter)
+import qualified Data.Map as M (Map, insert, lookup, alter, toList)
 -- -- heaps
 -- import qualified Data.Heap as H (Heap, empty, null, size, insert, viewMin, deleteMin, Entry(..), )
 -- hoauth2
@@ -241,7 +243,7 @@ instance Show OAuthSessionError where
  OASEJWTException jwtes -> unwords ["JWT error(s):", show jwtes]
  OASENoOpenID -> unwords ["No ID token found. Ensure 'openid' scope appears in token request"]
 
-
+-- | Insert or update a token in the 'Tokens' object
 updateToken :: (MonadIO m, Ord uid) =>
  Tokens uid OAuth2Token
  -> uid -- ^ user id
@@ -257,13 +259,15 @@ updateToken ts uid oat = do
  writeTVar ts (TokensData m')
  pure ein
 
+-- | Remove a user, i.e. they will have to authenticate once more
 expireUser :: (MonadIO m, Ord uid) =>
  Tokens uid t
  -> uid -- ^ user identifier e.g. @sub@
  -> m ()
 expireUser ts uid =
  atomically $ modifyTVar ts $ \td -> td{ thUsersMap = M.alter (const Nothing) uid (thUsersMap td)}
 
+-- | Look up a user identifier and return their current token, if any
 lookupUser :: (MonadIO m, Ord uid) =>
  Tokens uid t
  -> uid -- ^ user identifier e.g. @sub@
@@ -272,11 +276,22 @@ lookupUser ts uid = atomically $ do
  thp <- readTVar ts
  pure $ M.lookup uid (thUsersMap thp)
 
+-- | return a list representation of the 'Tokens' object
+tokensToList :: MonadIO m => Tokens k a -> m [(k, a)]
+tokensToList ts = atomically $ do
+ (TokensData m) <- readTVar ts
+ pure $ M.toList m
+
+-- | Create an empty 'Tokens' object
+newTokens :: (MonadIO m, Ord uid) => m (Tokens uid t)
+newTokens = newTVarIO (TokensData mempty)
+
 -- | transactional token store
 type Tokens uid t = TVar (TokensData uid t)
-data TokensData uid t = TokensData {
+newtype TokensData uid t = TokensData {
  thUsersMap :: M.Map uid t
- }
+ } deriving (Eq, Show)
+
 
 
 -- | Decode and validate ID token

stack.yaml

@@ -36,7 +36,6 @@ packages:
 # forks / in-progress versions pinned to a git hash. For extra:
 #
 extra-deps:
-- hoauth2-2.6.0
 - validation-selective-0.2.0.0
 - selective-0.6
 
@@ -53,9 +52,9 @@ extra-deps:
 # flags: {}
 
 # Extra package databases containing global packages
-# extra-package-dbs: []
+# extra-package-Control: []
 
-# Control whether we use the GHC we find on the path
+# dbs whether we use the GHC we find on the path
 # system-ghc: true
 #
 # Require a specific version of Stack, using version ranges