clarify auth code grant

unfoldml · Jun 20, 2023 · 6df065b · 6df065b
1 parent 553b8b1
commit 6df065b
Show file tree

Hide file tree

Showing 7 changed files with 164 additions and 29 deletions.
diff --git a/ms-auth/README.md b/ms-auth/README.md
@@ -9,7 +9,12 @@ Haskell client bindings to the [Microsoft Identity / Active Directory API]().
 
 ## Introduction
 
-This library provides helpers for building token-based authentication flows e.g. Client Credentials (App-only) and On-Behalf-Of (Delegated), as well as for keeping tokens up to date in the background.
+This library provides helpers for building token-based authentication flows within server-based web apps e.g. 
+
+* [Client Credentials](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-client-creds-grant-flow) (server/server or automation accounts)
+* [Authorization Code](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-auth-code-flow) (with human users being prompted to delegate some access rights to the app)
+
+, as well as for keeping tokens up to date in the background.
 
 
 ## Status

diff --git a/ms-auth/src/Network/OAuth2/Session.hs b/ms-auth/src/Network/OAuth2/Session.hs
@@ -5,7 +5,7 @@
 {-# options_ghc -Wno-unused-imports #-}
 -- | MS Identity user session based on OAuth tokens
 --
--- provides both Delegated permission flow (user-based) and App-only (e.g. server-server and automation accounts)
+-- provides both Authorization Code Grant flow (user-based) and App-only (e.g. server-server and automation accounts)
 module Network.OAuth2.Session (
   -- * Azure App Service
   withAADUser
@@ -15,7 +15,7 @@ module Network.OAuth2.Session (
   , expireToken
   , readToken
   , fetchUpdateToken
-  -- * Delegated permissions flow
+  -- * Auth code grant flow
   -- ** OAuth endpoints
   , loginEndpoint
   , replyEndpoint
@@ -132,8 +132,7 @@ withAADUser ts loginURI act = aadHeaderIdToken $ \usub -> do
 
 -- * App-only authorization scenarios (i.e via automation accounts. Human users not involved)
 
-
--- app has one token at a time
+-- | App has (at most) one token at a time
 type Token t = TVar (Maybe t)
 
 newNoToken :: MonadIO m => m (Token t)
@@ -181,7 +180,7 @@ updateToken ts oat = do
 
 
 
--- * Delegated permission flow (i.e. human user involved)
+-- * Auth code grant flow (i.e. human user involved)
 
 -- | Login endpoint
 --
@@ -224,7 +223,7 @@ replyH idpApp ts mgr = do
          Just codeP -> do
            let
              etoken = ExchangeToken $ TL.toStrict codeP
-           _ <- fetchUpdateTokenDeleg ts idpApp mgr etoken
+           _ <- fetchUpdateTokenACG ts idpApp mgr etoken
            pure ()
          Nothing -> throwE OASEExchangeTokenNotFound
 
@@ -239,13 +238,13 @@ replyH idpApp ts mgr = do
 
 -- | 1) the ExchangeToken arrives with the redirect once the user has approved the scopes in the browser
 -- https://learn.microsoft.com/en-us/graph/auth-v2-user?view=graph-rest-1.0&tabs=http#authorization-response
-fetchUpdateTokenDeleg :: MonadIO m =>
+fetchUpdateTokenACG :: MonadIO m =>
                          Tokens UserSub OAuth2Token
                       -> IdpApplication 'AuthorizationCode AzureAD
                       -> Manager
                       -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes
                       -> ExceptT OAuthSessionError m OAuth2Token
-fetchUpdateTokenDeleg ts idpApp mgr etoken = ExceptT $ do
+fetchUpdateTokenACG ts idpApp mgr etoken = ExceptT $ do
   tokenResp <- runExceptT $ conduitTokenRequest idpApp mgr etoken -- OAuth2 token
   case tokenResp of
     Right oat -> case idToken oat of
@@ -254,20 +253,20 @@ fetchUpdateTokenDeleg ts idpApp mgr etoken = ExceptT $ do
         idtClaimsE <- decValidIdToken idt -- decode and validate ID token
         case idtClaimsE of
           Right uid -> do
-            _ <- refreshLoopDeleg ts idpApp mgr uid oat -- fork a thread and start refresh loop for this user
+            _ <- refreshLoopACG ts idpApp mgr uid oat -- fork a thread and start refresh loop for this user
             pure $ Right oat
           Left es -> pure $ Left (OASEJWTException es) -- id token validation failed
     Left es -> pure $ Left (OASEOAuth2Errors es)
 
 -- | 2) fork a thread and start token refresh loop for user @uid@
-refreshLoopDeleg :: (MonadIO m, Ord uid, HasRefreshTokenRequest a) =>
+refreshLoopACG :: (MonadIO m, Ord uid, HasRefreshTokenRequest a) =>
                     Tokens uid OAuth2Token
                  -> IdpApplication a i
                  -> Manager
                  -> uid -- ^ user ID
                  -> OAuth2Token
                  -> m ThreadId
-refreshLoopDeleg ts idpApp mgr uid oaToken = liftIO $ forkFinally (act oaToken) cleanup
+refreshLoopACG ts idpApp mgr uid oaToken = liftIO $ forkFinally (act oaToken) cleanup
   where
     cleanup = \case
       Left _ -> do

diff --git a/ms-azure-api/CHANGELOG.md b/ms-azure-api/CHANGELOG.md
@@ -8,6 +8,12 @@ and this project adheres to the
 
 ## Unreleased
 
+## 0.2
+
+MSAzureAPI.StorageServices.FileService. listDirectoriesAndFiles
+
+Add XML support via `xeno` and `xmlbf` to parse `listDirectoriesAndFiles` response bodies
+
 ## 0.1.0.0
 
 First release
diff --git a/ms-azure-api/README.md b/ms-azure-api/README.md
@@ -11,7 +11,7 @@ Haskell client bindings to the [Microsoft Azure API]().
 
 This library provides the client interface (under the `MSAzureAPI` namespace).
 
-Authentication can be implemented with the @ms-auth@ library.
+Authentication can be implemented with the `ms-auth` library.
 
 ## Status
 

diff --git a/ms-azure-api/ms-azure-api.cabal b/ms-azure-api/ms-azure-api.cabal
@@ -1,8 +1,8 @@
 name:                ms-azure-api
-version:             0.1.0.0
+version:             0.2.0.0
 synopsis:            Microsoft Azure API
 description:         Bindings to the Microsoft Azure API
-homepage:            https://github.com/unfoldml/ms-api
+homepage:            https://github.com/unfoldml/ms-graph-api
 license:             BSD3
 license-file:        LICENSE
 author:              Marco Zocca
@@ -34,6 +34,9 @@ library
                      , time >= 1.8
                      , transformers >= 0.5
                      , unliftio
+                     , xeno
+                     , xmlbf
+                     , xmlbf-xeno
   ghc-options:         -Wall
                        -Wcompat
                        -Wno-unused-imports
@@ -47,4 +50,4 @@ library
 
 source-repository head
   type:     git
-  location: https://github.com/unfoldml/ms-azure-api
+  location: https://github.com/unfoldml/ms-graph-api
diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs
@@ -5,8 +5,11 @@
 module MSAzureAPI.Internal.Common (
   APIPlane(..)
   , get
+  , getBs
   , getLbs
   , post
+  -- ** URL parameters
+  , (==:)
   -- ** Helpers
   , tryReq
   -- ** JSON
@@ -43,6 +46,11 @@ import Data.Text (Text, pack, unpack)
 import UnliftIO (MonadUnliftIO(..))
 import UnliftIO.Exception (try)
 
+-- | URL parameters
+(==:) :: Text -- ^ key
+      -> Text -- ^ value
+      -> Option 'Https
+(==:) = (=:)
 
 -- | @GET@ a 'LBS.ByteString' e.g. a file
 getLbs :: APIPlane
@@ -53,6 +61,15 @@ getLbs apiplane paths params tok = responseBody <$> req GET url NoReqBody lbsRes
     opts = auth <> params
     (url, auth) = msAzureReqConfig apiplane paths tok
 
+-- | @GET@ a 'BS.ByteString' e.g. a file
+getBs :: APIPlane
+      -> [Text] -- ^ URI path segments
+      -> Option 'Https -> AccessToken -> Req BS.ByteString
+getBs apiplane paths params tok = responseBody <$> req GET url NoReqBody bsResponse opts
+  where
+    opts = auth <> params
+    (url, auth) = msAzureReqConfig apiplane paths tok
+
 
 -- | Specialized version of 'try' to 'HttpException's
 --

diff --git a/ms-azure-api/src/MSAzureAPI/StorageServices/FileService.hs b/ms-azure-api/src/MSAzureAPI/StorageServices/FileService.hs
@@ -3,26 +3,49 @@
 -- authorize with AD : https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-azure-active-directory
 --
 -- permissions for calling data operations : https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-azure-active-directory#permissions-for-calling-data-operations
-module MSAzureAPI.StorageServices.FileService (getFile) where
-
+module MSAzureAPI.StorageServices.FileService (
+  -- * Files
+  getFile
+  -- * Directories
+  , listDirectoriesAndFiles
+  , DirItem(..)
+  ) where
+
+import Control.Applicative (Alternative(..))
 import Control.Monad.IO.Class (MonadIO(..))
+import Data.Foldable (asum)
+import Data.Functor (void)
+import Data.Maybe (listToMaybe)
+import qualified Text.ParserCombinators.ReadP as RP (ReadP, readP_to_S, choice, many, between, char, string, satisfy)
 
 -- bytestring
+import qualified Data.ByteString as BS (ByteString)
 import qualified Data.ByteString.Char8 as BS8 (pack, unpack)
 import qualified Data.ByteString.Lazy as LBS (ByteString)
 -- hoauth2
 -- import Network.OAuth.OAuth2 (OAuth2Token(..))
 import Network.OAuth.OAuth2.Internal (AccessToken(..))
 -- req
-import Network.HTTP.Req (Req, Url, Option, Scheme(..), header)
+import Network.HTTP.Req (Req, Url, Option, Scheme(..), header, (=:))
 -- text
 import Data.Text (Text, pack, unpack)
+import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict)
 -- time
 import Data.Time (UTCTime, getCurrentTime)
 import Data.Time.Format (FormatTime, formatTime, defaultTimeLocale)
 import Data.Time.LocalTime (getZonedTime)
+-- xeno
+import qualified Xeno.DOM.Robust as X (Node, Content(..), name, contents, children)
+-- xmlbf-xeno
+import qualified Xmlbf.Xeno as XB (fromRawXml)
+-- xmlbf
+import qualified Xmlbf as XB (Parser, runParser, pElement, pText)
+
+import MSAzureAPI.Internal.Common (APIPlane(..), (==:), get, getBs, post, getLbs)
+
+
+
 
-import MSAzureAPI.Internal.Common (APIPlane(..), get, post, getLbs)
 
 {- | Headers:
 
@@ -92,16 +115,98 @@ getFile acct fshare fpath atok = do
 
 -- | list directories and files  https://learn.microsoft.com/en-us/rest/api/storageservices/list-directories-and-files#request 
 --
--- GET https://myaccount.file.core.windows.net/myshare/mydirectorypath?restype=directory&comp=list
--- listDirectoryAndFiles
+-- @GET https:\/\/myaccount.file.core.windows.net\/myshare\/mydirectorypath?restype=directory&comp=list@
+listDirectoriesAndFiles :: Text -- ^ storage account
+                        -> Text -- ^ file share
+                        -> Text -- ^ directory path, including directories
+                        -> AccessToken
+                        -> Req (Either String [DirItem])
+listDirectoriesAndFiles acct fshare fpath atok = do
+  os <- msStorageReqHeaders
+  bs <- getBs (APData domain) pth (os <> "restype" ==: "directory" <> "comp" ==: "list") atok
+  pure $ parseXML listDirectoriesP bs
+  where
+    domain = acct <> ".file.core.windows.net"
+    pth = [fshare, fpath]
 
---
--- Path component 	Description
---
--- myaccount 	The name of your storage account.
--- myshare 	The name of your file share.
--- mydirectorypath 	Optional. The path to the directory.
--- myfile 	The name of the file.
+-- | Directory item, as returned by 'listDirectoriesAndFiles'
+data DirItem = DIFile {diId :: Text, diName :: Text}
+             | DIDirectory {diId :: Text, diName :: Text}
+             deriving (Show)
+
+-- | XML parser for the response body format shown here: https://learn.microsoft.com/en-us/rest/api/storageservices/list-directories-and-files#response-body
+listDirectoriesP :: XB.Parser [DirItem]
+listDirectoriesP = do
+  tag "EnumerationResults" $ do
+    enumResultsIgnore
+    es <- entries
+    selfClosing "NextMarker"
+    pure es
+
+enumResultsIgnore :: XB.Parser ()
+enumResultsIgnore = ignoreList ["Marker", "Prefix", "MaxResults", "DirectoryId"]
+
+entries :: XB.Parser [DirItem]
+entries = tag "Entries" $ many (file <|> directory)
+
+file :: XB.Parser DirItem
+file = tag "File" $ do
+  fid <- fileId
+  fname <- fileName
+  properties
+  entryFooter
+  pure $ DIFile fid fname
+
+directory :: XB.Parser DirItem
+directory = tag "Directory" $ do
+  fid <- fileId
+  fname <- fileName
+  properties
+  entryFooter
+  pure $ DIDirectory fid fname
+
+
+
+entryFooter :: XB.Parser ()
+entryFooter = ignoreList ["Attributes", "PermissionKey"]
+
+fileId :: XB.Parser Text
+fileId = TL.toStrict <$> tag "FileId" anystring
+
+fileName :: XB.Parser Text
+fileName = TL.toStrict <$> tag "Name" anystring
+
+properties :: XB.Parser ()
+properties = tag "Properties" $
+  ignoreList ["Content-Length", "CreationTime", "LastAccessTime", "LastWriteTime", "ChangeTime", "Last-Modified", "Etag"]
+
+ignoreList :: [Text] -> XB.Parser ()
+ignoreList ns = void $ many (asum (map (`XB.pElement` XB.pText) ns))
+
+selfClosing :: Text -> XB.Parser ()
+selfClosing t = tag t (pure ())
+
+
+anystring :: XB.Parser TL.Text
+anystring = XB.pText
+tag :: Text -> XB.Parser a -> XB.Parser a
+tag = XB.pElement
+
+parseXML :: XB.Parser b -> BS.ByteString -> Either String b
+parseXML p bs = XB.fromRawXml bs >>= XB.runParser p
+
+
+
+-- -- t0, t1, tdir, tfile, tentries :: String
+-- t0, t1, t1', tfile :: BS.ByteString
+-- t0 = "<Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties>"
+
+-- t1' = "<?xml version=\"1.0\" encoding=\"utf-8\"?> <EnumerationResults ServiceEndpoint=\"https://myaccount.file.core.windows.net/\" ShareName=\"myshare\" ShareSnapshot=\"date-time\" DirectoryPath=\"directory-path\"> <Marker>string-value</Marker> <Prefix>string-value</Prefix> <MaxResults>int-value</MaxResults> <DirectoryId>directory-id</DirectoryId> <Entries> <File> <FileId>file-id</FileId> <Name>file-name</Name> <Properties> <Content-Length>size-in-bytes</Content-Length> <CreationTime>datetime</CreationTime> <LastAccessTime>datetime</LastAccessTime> <LastWriteTime>datetime</LastWriteTime> <ChangeTime>datetime</ChangeTime> <Last-Modified>datetime</Last-Modified> <Etag>etag</Etag> </Properties> <Attributes>Archive|Hidden|Offline|ReadOnly</Attributes> <PermissionKey>4066528134148476695*1</PermissionKey> </File> <Directory> <FileId>file-id</FileId> <Name>directory-name</Name> <Properties> <CreationTime>datetime</CreationTime> <LastAccessTime>datetime</LastAccessTime> <LastWriteTime>datetime</LastWriteTime> <ChangeTime>datetime</ChangeTime> <Last-Modified>datetime</Last-Modified> <Etag>etag</Etag> </Properties> <Attributes>Archive|Hidden|Offline|ReadOnly</Attributes> <PermissionKey>4066528134148476695*1</PermissionKey> </Directory> </Entries> <NextMarker /> </EnumerationResults>"
+
+-- t1 = "<?xml version=\"1.0\" encoding=\"utf-8\"?><EnumerationResults ServiceEndpoint=\"https://myaccount.file.core.windows.net/\" ShareName=\"myshare\" ShareSnapshot=\"date-time\" DirectoryPath=\"directory-path\"><Marker>string-value</Marker><Prefix>string-value</Prefix><MaxResults>int-value</MaxResults><DirectoryId>directory-id</DirectoryId><Entries><File><FileId>file-id</FileId><Name>file-name</Name><Properties><Content-Length>size-in-bytes</Content-Length><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></File><Directory><FileId>file-id</FileId><Name>directory-name</Name><Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></Directory></Entries><NextMarker /></EnumerationResults>"
 
+-- -- tdir = "<Directory><FileId>file-id</FileId><Name>directory-name</Name><Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></Directory>"
 
+-- tfile = "<File><FileId>file-id</FileId><Name>file-name</Name><Properties><Content-Length>size-in-bytes</Content-Length><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></File>"
 
+-- -- tentries = "<Entries><File><FileId>file-id</FileId><Name>file-name</Name><Properties><Content-Length>size-in-bytes</Content-Length><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></File><Directory><FileId>file-id</FileId><Name>directory-name</Name><Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></Directory></Entries>"