From 0366bec739042798cb2ed6e4a47d8c0138b3a784 Mon Sep 17 00:00:00 2001
From: Marco Zocca <marco.zocca@unfoldml.com>
Date: Sat, 17 Jun 2023 23:18:22 +0200
Subject: [PATCH] v 0.4 add missing Session functions

---
 .github/workflows/haskell.yml |  2 +-
 CHANGELOG.md                  |  4 +++-
 ms-graph-api.cabal            |  2 +-
 src/Network/OAuth2/Session.hs | 23 +++++++++++++++++++----
 stack.yaml                    |  5 ++---
 5 files changed, 26 insertions(+), 10 deletions(-)

diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
index cad9635..f9df609 100644
--- a/.github/workflows/haskell.yml
+++ b/.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
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 50bf4db..c0ad40b 100644
--- a/CHANGELOG.md
+++ b/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
diff --git a/ms-graph-api.cabal b/ms-graph-api.cabal
index 7be0e01..ae2094f 100644
--- a/ms-graph-api.cabal
+++ b/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
diff --git a/src/Network/OAuth2/Session.hs b/src/Network/OAuth2/Session.hs
index 775d91b..efb9747 100644
--- a/src/Network/OAuth2/Session.hs
+++ b/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,6 +259,7 @@ 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@
@@ -264,6 +267,7 @@ expireUser :: (MonadIO m, Ord uid) =>
 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
diff --git a/stack.yaml b/stack.yaml
index ceb9350..e2f0639 100644
--- a/stack.yaml
+++ b/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