diff --git a/ms-auth/README.md b/ms-auth/README.md index 7431954..96ea21b 100644 --- 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 index f77a58b..997519d 100644 --- 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 index b5145ae..5d1fc14 100644 --- 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 index b19a603..6690003 100644 --- 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 index 5e535ac..08aaf15 100644 --- 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 index b3d26d8..b816291 100644 --- 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 index 93634e7..9044eab 100644 --- 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 = "datetimedatetimedatetimedatetimedatetimeetag" + +-- t1' = " string-value string-value int-value directory-id file-id file-name size-in-bytes datetime datetime datetime datetime datetime etag Archive|Hidden|Offline|ReadOnly 4066528134148476695*1 file-id directory-name datetime datetime datetime datetime datetime etag Archive|Hidden|Offline|ReadOnly 4066528134148476695*1 " + +-- t1 = "string-valuestring-valueint-valuedirectory-idfile-idfile-namesize-in-bytesdatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1file-iddirectory-namedatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1" +-- -- tdir = "file-iddirectory-namedatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1" +-- tfile = "file-idfile-namesize-in-bytesdatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1" +-- -- tentries = "file-idfile-namesize-in-bytesdatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1file-iddirectory-namedatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1"