graph api v0.9

unfoldml · Jul 2, 2023 · c02d316 · c02d316
1 parent ec85173
commit c02d316
Show file tree

Hide file tree

Showing 9 changed files with 100 additions and 67 deletions.
diff --git a/ms-graph-api-test/app/Main.hs b/ms-graph-api-test/app/Main.hs
@@ -5,11 +5,12 @@
 module Main (main) where
 
 import Control.Monad.IO.Class (MonadIO(..))
+import Data.Maybe (fromMaybe)
 
 -- aeson-pretty
 import qualified Data.Aeson.Encode.Pretty as A (encodePretty)
 -- bytestring
-import qualified Data.ByteString.Lazy.Char8 as LBS (putStrLn)
+import qualified Data.ByteString.Lazy.Char8 as LBS (putStrLn, pack)
 -- hoauth2
 import Network.OAuth.OAuth2 (OAuth2Token(..))
 import Network.OAuth2.Experiment (IdpApplication, GrantTypeFlow(..))
@@ -18,7 +19,7 @@ import Network.HTTP.Client (Manager, newManager)
 -- http-client-tls
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 -- req
-import Network.HTTP.Req (runReq, defaultHttpConfig, httpConfigAltManager)
+import Network.HTTP.Req (HttpConfig, runReq, defaultHttpConfig, httpConfigAltManager)
 -- scotty
 import Web.Scotty.Trans (ScottyT, scottyT, get, text, html, RoutePattern, middleware)
 -- text
@@ -34,8 +35,10 @@ import URI.ByteString.QQ (uri)
 -- wai-extra
 import Network.Wai.Middleware.RequestLogger (logStdoutDev)
 
+import qualified MSGraphAPI as MSG (Collection(..), run, withTLS)
+import qualified MSGraphAPI.Files.Drive as MSD (Drive(..), listDrivesGroup)
 import qualified MSGraphAPI.Files.DriveItem as MSDI (listRootChildrenMe)
-import qualified MSGraphAPI.Users.Group as MSGU (getMeJoinedTeams)
+import qualified MSGraphAPI.Users.Group as MSGU (Group(..), getMeJoinedTeams, getGroupsDriveItems)
 import qualified MSGraphAPI.Users.User as MSG (getMe, User(..))
 import Network.OAuth2.Provider.AzureAD (OAuthCfg(..), azureOAuthADApp, AzureAD)
 import MSAuth (applyDotEnv, Tokens, newTokens, tokensToList, withAADUser, loginEndpoint, replyEndpoint, UserSub, Scotty, Action)
@@ -48,41 +51,55 @@ server :: MonadIO m => m ()
 server = do
  ts <- newTokens
  applyDotEnv (Just ".env")
- mgr <- liftIO $ newManager tlsManagerSettings
  ip <- idpApp
- let
- runR r = runReaderT r ts
- scottyT 3000 runR $ do
- middleware logStdoutDev
- loginEndpoint ip "/oauth/login"
- replyEndpoint ip ts mgr "/oauth/reply"
- allTokensEndpoint ts "/tokens"
- currentUsersEndpoint ts (Just mgr) "/me"
- meFilesEndpoint ts (Just mgr) "/me/files"
- meTeamsEndpoint ts (Just mgr) "/me/teams"
-
--- currentUserEndpoint :: MonadIO m =>
--- Tokens UserSub OAuth2Token
--- -> RoutePattern -> Scotty m ()
--- currentUserEndpoint ts pth = get pth $ withAADUser ts "/oauth/login" $ \oat -> do
--- let
--- t = accessToken oat
--- u <- runReq defaultHttpConfig $ MSG.getMe t
--- let
--- uname = MSG.uDisplayName u
--- h = TL.pack $ unwords ["<html>", "<h1>", T.unpack uname, "</h1>","</html>"]
--- html h
+ MSG.withTLS $ \hc mgr -> do
+ let
+ runR r = runReaderT r ts
+ scottyT 3000 runR $ do
+ middleware logStdoutDev
+ loginEndpoint ip "/oauth/login"
+ replyEndpoint ip ts mgr "/oauth/reply"
+
+ meGroupDrivesEndpoint ts hc "/me/group/drives"
+ currentUsersEndpoint ts hc "/me"
+ meFilesEndpoint ts hc "/me/files"
+ meTeamsEndpoint ts hc "/me/teams"
+
+
+groupDriveItems t = do
+ gs <- MSG.cValue <$> MSGU.getMeJoinedTeams t
+ traverse (\g -> MSGU.getGroupsDriveItems (MSGU.gId g) t ) gs
+
+meGroupDrivesEndpoint :: (MonadIO m) =>
+ Tokens a OAuth2Token
+ -> HttpConfig -> RoutePattern -> Scotty m ()
+meGroupDrivesEndpoint ts hc pth = get pth $ do
+ tsl <- tokensToList ts
+ let
+ f (_, oat) = do
+ let
+ t = accessToken oat
+ iteme <- MSG.run hc $ groupDriveItems t
+ case iteme of
+ Right item -> pure $ A.encodePretty item
+ Left e -> pure $ LBS.pack $ show e
+ rows <- traverse f tsl
+ text $ TL.decodeUtf8 $ mconcat rows
+
+
+
+
 
 meTeamsEndpoint :: (MonadIO m) =>
  Tokens a OAuth2Token
- -> Maybe Manager -> RoutePattern -> Scotty m ()
-meTeamsEndpoint ts mmgr pth = get pth $ do
+ -> HttpConfig -> RoutePattern -> Scotty m ()
+meTeamsEndpoint ts hc pth = get pth $ do
  tsl <- tokensToList ts
  let
  f (_, oat) = do
  let
  t = accessToken oat
- item <- runReq defaultHttpConfig{ httpConfigAltManager = mmgr } $ MSGU.getMeJoinedTeams t
+ item <- runReq hc $ MSGU.getMeJoinedTeams t
  let
  js = A.encodePretty item
  pure js
@@ -91,14 +108,14 @@ meTeamsEndpoint ts mmgr pth = get pth $ do
 
 meFilesEndpoint :: (MonadIO m) =>
  Tokens a OAuth2Token
- -> Maybe Manager -> RoutePattern -> Scotty m ()
-meFilesEndpoint ts mmgr pth = get pth $ do
+ -> HttpConfig -> RoutePattern -> Scotty m ()
+meFilesEndpoint ts hc pth = get pth $ do
  tsl <- tokensToList ts
  let
  f (_, oat) = do
  let
  t = accessToken oat
- item <- runReq defaultHttpConfig{ httpConfigAltManager = mmgr } $ MSDI.listRootChildrenMe t
+ item <- runReq hc $ MSDI.listRootChildrenMe t
  let
  js = A.encodePretty item
  pure js
@@ -107,15 +124,15 @@ meFilesEndpoint ts mmgr pth = get pth $ do
 
 currentUsersEndpoint :: (MonadIO m) =>
  Tokens a OAuth2Token
- -> Maybe Manager -- ^ if Nothing it uses the default implicit connection manager
+ -> HttpConfig
  -> RoutePattern -> Scotty m ()
-currentUsersEndpoint ts mmgr pth = get pth $ do
+currentUsersEndpoint ts hc pth = get pth $ do
  tsl <- tokensToList ts
  let
  f (_, oat) = do
  let
  t = accessToken oat
- usr <- runReq defaultHttpConfig{ httpConfigAltManager = mmgr } $ MSG.getMe t
+ usr <- runReq hc $ MSG.getMe t
  let
  row = unwords ["<tr><td>", show usr, "</td></tr>"]
  pure row
@@ -141,7 +158,7 @@ table mm = TL.pack ("<table>" <> foldMap insf mm <> "</table>")
 idpApp :: MonadIO m => m (IdpApplication 'AuthorizationCode AzureAD)
 idpApp = azureOAuthADApp (OAuthCfg
  "ms-graph-api-test"
- ["profile", "email", "User.Read", "Files.Read", "Team.ReadBasic.All"]
+ ["profile", "email", "User.Read", "Files.Read.All", "Team.ReadBasic.All"]
  "abcd1234"
  [uri|https://66e7-213-89-187-253.ngrok-free.app/oauth/reply|]
  )

diff --git a/ms-graph-api-test/ms-graph-api-test.cabal b/ms-graph-api-test/ms-graph-api-test.cabal
@@ -19,23 +19,25 @@ library
  default-language: Haskell2010
  hs-source-dirs: src
  exposed-modules: Lib
- build-depends: base >= 4.7 && < 5
+ build-depends: base >= 4.7 && < 5,
+ directory >= 1.3.6.2
  ghc-options: -Wall
 
 executable ms-graph-api-test
  default-language: Haskell2010
  hs-source-dirs: app
  main-is: Main.hs
- build-depends: base
- , aeson
+ build-depends: aeson
  , aeson-pretty
+ , base
  , bytestring
+ , directory >= 1.3.6.2
  , hoauth2 == 2.6.0
  , http-client
  , http-client-tls >= 0.3
+ , ms-auth >= 0.2
  , ms-graph-api
  , ms-graph-api-test
- , ms-auth >= 0.2
  , req
  , scotty
  , text >= 1.2.5.0

diff --git a/ms-graph-api/CHANGELOG.md b/ms-graph-api/CHANGELOG.md
@@ -13,6 +13,9 @@ and this project adheres to the
 
 MSGraphAPI.Files.Drive
 
+*Breaking changes*
+- withTLS changed signature: the inner continuation has an additional Manager parameter
+
 
 ## 0.8.0.0
 
@@ -28,8 +31,7 @@ MSGraphAPI.ChangeNotifications.Subscription:
 - add createSubscription
 
 *Breaking changes*
-
-Moved the Network/* module hierarchy to the `ms-auth` package shared with `ms-azure-api`.
+- Moved the Network/* module hierarchy to the `ms-auth` package shared with `ms-azure-api`.
 
 ## 0.6.0.0
 

diff --git a/ms-graph-api/ms-graph-api.cabal b/ms-graph-api/ms-graph-api.cabal
@@ -27,11 +27,12 @@ library
  MSGraphAPI.Files.Drive
  MSGraphAPI.Files.DriveItem
  other-modules: MSGraphAPI.Internal.Common
- build-depends: base >= 4.7 && < 5
- , aeson
+ build-depends: aeson
+ , base >= 4.7 && < 5
  , bytestring
  , containers
  , hoauth2 == 2.6.0
+ , http-client >= 0.7.13.1
  , http-client-tls >= 0.3
  , http-types
  , modern-uri

diff --git a/ms-graph-api/src/MSGraphAPI/Files/Drive.hs b/ms-graph-api/src/MSGraphAPI/Files/Drive.hs
@@ -5,25 +5,25 @@ module MSGraphAPI.Files.Drive (
  , Drive(..)
  ) where
 
-import Control.Applicative (Alternative(..))
-import Data.Int (Int32)
+-- import Control.Applicative (Alternative(..))
+-- import Data.Int (Int32)
 import GHC.Generics (Generic(..))
 
 -- aeson
-import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), Value, genericParseJSON, (.:), (.:?), Object, withObject, Key)
-import qualified Data.Aeson.Types as A (Parser)
+import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON)
+-- import qualified Data.Aeson.Types as A (Parser)
 -- bytestring
-import qualified Data.ByteString.Lazy as LBS (ByteString)
+-- import qualified Data.ByteString.Lazy as LBS (ByteString)
 -- hoauth
 import Network.OAuth.OAuth2.Internal (AccessToken(..))
 -- req
 import Network.HTTP.Req (Req)
 -- text
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text)
 -- time
 import Data.Time (ZonedTime)
 
-import qualified MSGraphAPI.Internal.Common as MSG (get, getLbs, post, Collection, aesonOptions)
+import qualified MSGraphAPI.Internal.Common as MSG (get, Collection, aesonOptions)
 
 -- | The top-level object that represents a user's OneDrive or a document library in SharePoint.
 --
@@ -53,4 +53,4 @@ listDrivesMe = MSG.get ["me", "drives"] mempty
 -- @GET \/groups\/{groupId}\/drives@
 listDrivesGroup :: Text -- ^ group ID
  -> AccessToken -> Req (MSG.Collection Drive)
-listDrivesGroup gid = MSG.get ["groups", gid, "drives"]
+listDrivesGroup gid = MSG.get ["groups", gid, "drives"] mempty
diff --git a/ms-graph-api/src/MSGraphAPI/Files/DriveItem.hs b/ms-graph-api/src/MSGraphAPI/Files/DriveItem.hs
@@ -18,7 +18,7 @@ import Data.Int (Int32)
 import GHC.Generics (Generic(..))
 
 -- aeson
-import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), Value, genericParseJSON, (.:), (.:?), Object, withObject, Key)
+import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON, (.:), Object, withObject, Key)
 import qualified Data.Aeson.Types as A (Parser)
 -- bytestring
 import qualified Data.ByteString.Lazy as LBS (ByteString)
@@ -27,11 +27,11 @@ import Network.OAuth.OAuth2.Internal (AccessToken(..))
 -- req
 import Network.HTTP.Req (Req)
 -- text
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text)
 -- time
-import Data.Time (LocalTime, ZonedTime)
+import Data.Time (ZonedTime)
 
-import qualified MSGraphAPI.Internal.Common as MSG (get, getLbs, post, Collection, aesonOptions)
+import qualified MSGraphAPI.Internal.Common as MSG (get, getLbs, Collection, aesonOptions)
 
 -- | The 'DriveItem' resource represents a file, folder, or other item stored in a drive.
 --

diff --git a/ms-graph-api/src/MSGraphAPI/Internal/Common.hs b/ms-graph-api/src/MSGraphAPI/Internal/Common.hs
@@ -45,6 +45,8 @@ import qualified Data.ByteString.Lazy.Char8 as LBS8 (pack, unpack, putStrLn)
 -- hoauth2
 import Network.OAuth.OAuth2 (OAuth2Token(..))
 import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))
+-- http-client
+import Network.HTTP.Client (Manager)
 -- http-client-tls
 import Network.HTTP.Client.TLS (newTlsManager)
 -- modern-uri
@@ -68,13 +70,13 @@ tryReq = try
 
 -- | Create a new TLS manager, which should be reused throughout the program
 withTLS :: MonadIO m =>
- (HttpConfig -> m b) -- ^ user program
+ (HttpConfig -> Manager -> m b) -- ^ user program
  -> m b
 withTLS act = do
  mgr <- newTlsManager
  let
  hc = defaultHttpConfig { httpConfigAltManager = Just mgr }
- act hc
+ act hc mgr
 
 -- | Run a 'Req' computation
 run :: MonadIO m =>

diff --git a/ms-graph-api/src/MSGraphAPI/Users/Group.hs b/ms-graph-api/src/MSGraphAPI/Users/Group.hs
@@ -12,15 +12,15 @@ module MSGraphAPI.Users.Group (
 import GHC.Generics (Generic(..))
 
 -- aeson
-import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), eitherDecode, genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=))
+import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON)
 -- hoauth
 import Network.OAuth.OAuth2.Internal (AccessToken(..))
 -- req
 import Network.HTTP.Req (Req)
 -- text
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text)
 
-import qualified MSGraphAPI.Internal.Common as MSG (Collection(..), get, post, aesonOptions)
+import qualified MSGraphAPI.Internal.Common as MSG (Collection(..), get, aesonOptions)
 import MSGraphAPI.Files.DriveItem (DriveItem)
 
 -- | Groups are collections of principals with shared access to resources in Microsoft services or in your app. Different principals such as users, other groups, devices, and applications can be part of groups. 
@@ -33,7 +33,7 @@ data Group = Group {
  } deriving (Eq, Ord, Show, Generic)
 instance A.FromJSON Group where
  parseJSON = A.genericParseJSON (MSG.aesonOptions "g")
-instance A.ToJSON Group 
+instance A.ToJSON Group
 
 -- | Get the teams in Microsoft Teams that the given user is a direct member of.
 --
@@ -57,6 +57,8 @@ getMeJoinedTeams = MSG.get ["me", "joinedTeams"] mempty
 -- @GET \/groups\/{group-id}\/drive\/root\/children@
 --
 -- https://learn.microsoft.com/en-us/graph/api/driveitem-list-children?view=graph-rest-1.0&tabs=http
+--
+-- NB : requires @Files.Read.All@, since it tries to access all files a user has access to.
 getGroupsDriveItems :: Text -- ^ Group ID
  -> AccessToken -> Req (MSG.Collection DriveItem)
 getGroupsDriveItems gid = MSG.get ["groups", gid, "drive", "root", "children"] mempty

diff --git a/ms-graph-api/src/MSGraphAPI/Users/User.hs b/ms-graph-api/src/MSGraphAPI/Users/User.hs
@@ -1,27 +1,34 @@
 -- | Users.User
-module MSGraphAPI.Users.User where
+module MSGraphAPI.Users.User (
+ get
+ , getMe
+ -- * types
+ , User(..)) where
 
 import GHC.Generics (Generic(..))
 
 -- aeson
-import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=))
+import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON)
 -- hoauth
 import Network.OAuth.OAuth2.Internal (AccessToken(..))
 -- req
 import Network.HTTP.Req (Req)
 -- text
-import Data.Text (Text, pack, unpack)
-
-import qualified MSGraphAPI.Internal.Common as MSG (get, post, aesonOptions)
+import Data.Text (Text)
 
+import qualified MSGraphAPI.Internal.Common as MSG (get, aesonOptions)
 
+-- | Representation of a user in the MS Graph API
+--
+-- https://learn.microsoft.com/en-us/graph/api/resources/users?view=graph-rest-1.0
 data User = User {
  uId :: Text
  , uUserPrincipalName :: Text
  , uDisplayName :: Text
  } deriving (Eq, Ord, Show, Generic)
 instance A.FromJSON User where
  parseJSON = A.genericParseJSON (MSG.aesonOptions "u")
+instance A.ToJSON User
 
 
 -- | Get user information