From d09e7899dec538eba064b090afe83f6c7b0cf7d4 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Fri, 11 Aug 2023 14:39:28 +0200 Subject: [PATCH] ms-auth and ms-azure-api new release --- .../src/Network/OAuth2/Provider/AzureAD.hs | 9 ++- ms-azure-api-test/LICENSE | 30 ++++++++++ ms-azure-api-test/app/Main.hs | 58 +++++++++++++++++-- ms-azure-api-test/ms-azure-api-test.cabal | 1 + ms-azure-api/src/MSAzureAPI.hs | 2 + ms-azure-api/src/MSAzureAPI/BotService.hs | 16 +++-- .../src/MSAzureAPI/Internal/Common.hs | 5 +- 7 files changed, 105 insertions(+), 16 deletions(-) create mode 100644 ms-azure-api-test/LICENSE diff --git a/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs b/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs index 22f35c9..88e0b1f 100644 --- a/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs +++ b/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs @@ -12,7 +12,6 @@ -- Azure Bot Framework is supported since v 0.4 module Network.OAuth2.Provider.AzureAD ( AzureAD - , AzureBotFramework -- * Environment variables , envClientId , envClientSecret @@ -123,7 +122,7 @@ defaultAzureADApp = -- Throws 'AzureADException' if @AZURE_CLIENT_ID@ and/or @AZURE_CLIENT_SECRET@ credentials are not found in the environment azureBotFrameworkADApp :: MonadIO m => TL.Text -- ^ app name - -> m (IdpApplication 'ClientCredentials AzureBotFramework) + -> m (IdpApplication 'ClientCredentials AzureAD) azureBotFrameworkADApp appname = do clid <- envClientId sec <- envClientSecret @@ -136,11 +135,11 @@ azureBotFrameworkADApp appname = do } -data AzureBotFramework = AzureBotFramework deriving (Eq, Show) +-- data AzureBotFramework = AzureBotFramework deriving (Eq, Show) -defaultAzureBotFrameworkIdp :: Idp AzureBotFramework +defaultAzureBotFrameworkIdp :: Idp AzureAD defaultAzureBotFrameworkIdp = Idp { - idpFetchUserInfo = authGetJSON @(IdpUserInfo AzureBotFramework) + idpFetchUserInfo = authGetJSON @(IdpUserInfo AzureAD) , idpTokenEndpoint = [uri|https://login.microsoftonline.com/botframework.com/oauth2/v2.0/token|] , idpUserInfoEndpoint = error $ unwords ["Azure Bot Framework Idp:", "OAuth user info endpoint is not defined"] , idpAuthorizeEndpoint = error $ unwords ["Azure Bot Framework Idp:", "OAuth authorize endpoint is not defined"] diff --git a/ms-azure-api-test/LICENSE b/ms-azure-api-test/LICENSE new file mode 100644 index 0000000..c5b6c16 --- /dev/null +++ b/ms-azure-api-test/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ms-azure-api-test/app/Main.hs b/ms-azure-api-test/app/Main.hs index 17930d7..b044e2d 100644 --- a/ms-azure-api-test/app/Main.hs +++ b/ms-azure-api-test/app/Main.hs @@ -1,28 +1,76 @@ {-# LANGUAGE DataKinds #-} {-# language OverloadedStrings #-} {-# language QuasiQuotes #-} +{-# language ScopedTypeVariables #-} +{-# options_ghc -Wno-unused-imports #-} module Main (main) where import Control.Monad.IO.Class (MonadIO(..)) +-- aeson +import Data.Aeson (eitherDecode) +-- dotenv-micro +import DotEnv.Micro (loadDotEnv) -- hoauth2 -import Network.OAuth.OAuth2 (OAuth2Token(..)) +import Network.OAuth.OAuth2 (OAuth2Token(..), AccessToken) import Network.OAuth2.Experiment (IdpApplication, GrantTypeFlow(..)) +-- http-client +import Network.HTTP.Client (Manager) +-- http-types +import Network.HTTP.Types.Status (status200) +-- req +import Network.HTTP.Req (HttpConfig) +-- scotty +import Web.Scotty.Trans (ScottyT, scottyT, get, post, json, text, html, jsonData, status, raise, RoutePattern, middleware) +-- text +import qualified Data.Text.Lazy as TL (Text, pack) +-- transformers +import Control.Monad.Trans.Reader (runReaderT) -- unliftio import UnliftIO (MonadUnliftIO(..)) import UnliftIO.Exception (throwIO) import UnliftIO.STM (STM, TVar, atomically, newTVarIO, readTVar, writeTVar, modifyTVar) -- uri-bytestring import URI.ByteString.QQ (uri) +-- wai-extra +import Network.Wai.Middleware.RequestLogger (logStdoutDev) -import Network.OAuth2.Provider.AzureAD (azureBotFrameworkADApp, AzureBotFramework) +import Network.OAuth2.Provider.AzureAD (azureBotFrameworkADApp, AzureAD) import MSAuth (Token, tokenUpdateLoop, readToken, UserSub, Scotty, Action) -import MSAzureAPI (tryReq) +import MSAzureAPI (tryReq, run, withTLS) +import MSAzureAPI.BotService (Activity, sendReply) main :: IO () -main = pure () +main = server + +server :: MonadIO m => m () +server = do + loadDotEnv Nothing + ip <- idpApp + withTLS $ \httpcfg mgr -> do + tv <- tokenUpdateLoop ip mgr + let + runR r = runReaderT r tv + scottyT 3000 runR $ do + middleware logStdoutDev + pong tv httpcfg "/pong" + + +pong :: (MonadIO m) => + Token OAuth2Token + -> HttpConfig -> RoutePattern -> Scotty m () +pong tv hc pth = post pth $ do + (acti :: Activity) <- jsonData + m <- (fmap accessToken) <$> readToken tv + case m of + Nothing -> raise "readToken: found Nothing" + Just atok -> do + ei <- run hc $ sendReply acti "It worked!" [] atok + case ei of + Right _ -> status status200 + Left e -> raise $ TL.pack (show e) -- also double check https://stackoverflow.com/a/63929994/2890063 in the AAD app manifest -idpApp :: MonadIO m => m (IdpApplication 'ClientCredentials AzureBotFramework) +idpApp :: MonadIO m => m (IdpApplication 'ClientCredentials AzureAD) idpApp = azureBotFrameworkADApp "ms-azure-bot-framework-api-test" diff --git a/ms-azure-api-test/ms-azure-api-test.cabal b/ms-azure-api-test/ms-azure-api-test.cabal index 82fbdda..962981c 100644 --- a/ms-azure-api-test/ms-azure-api-test.cabal +++ b/ms-azure-api-test/ms-azure-api-test.cabal @@ -36,6 +36,7 @@ executable ms-azure-api-test , hoauth2 == 2.6.0 , http-client , http-client-tls >= 0.3 + , http-types , ms-azure-api-test , ms-auth , ms-azure-api diff --git a/ms-azure-api/src/MSAzureAPI.hs b/ms-azure-api/src/MSAzureAPI.hs index d9aae7f..014c67b 100644 --- a/ms-azure-api/src/MSAzureAPI.hs +++ b/ms-azure-api/src/MSAzureAPI.hs @@ -1,6 +1,8 @@ module MSAzureAPI ( -- * HTTP request helpers tryReq + , run + , withTLS -- * Common types -- ** Collection , Collection diff --git a/ms-azure-api/src/MSAzureAPI/BotService.hs b/ms-azure-api/src/MSAzureAPI/BotService.hs index 2e2850d..67ffd76 100644 --- a/ms-azure-api/src/MSAzureAPI/BotService.hs +++ b/ms-azure-api/src/MSAzureAPI/BotService.hs @@ -95,16 +95,24 @@ instance A.FromJSON Activity where instance A.ToJSON Activity where toJSON = A.genericToJSON (aesonOptions "a") --- | https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-api-reference?view=azure-bot-service-4.0#attachment-object +-- | Message attachments +-- +-- https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-api-reference?view=azure-bot-service-4.0#attachment-object +-- +-- Attachments can be of many types but we currently only support adaptive cards data Attachment = Attachment { attContent :: AdaptiveCard - , attContentType :: Text } deriving (Show, Generic) instance A.FromJSON Attachment where parseJSON = A.genericParseJSON (aesonOptions "att") instance A.ToJSON Attachment where - toJSON = A.genericToJSON (aesonOptions "att") - + toJSON (Attachment ac) = A.object [ + "contentType" A..= ("application/vnd.microsoft.card.adaptive" :: String) + , "content" A..= ac + ] +-- | Adaptive Card API +-- +-- https://adaptivecards.io/explorer/AdaptiveCard.html data AdaptiveCard = AdaptiveCard { acBody :: [ACElement] } deriving (Show, Generic) instance A.FromJSON AdaptiveCard where diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs index 0482330..f74f57f 100644 --- a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs +++ b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs @@ -53,6 +53,7 @@ import qualified Data.ByteString.Char8 as BS8 (pack, unpack) import qualified Data.ByteString.Lazy as LBS (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS8 (pack, unpack, putStrLn) -- http-client +import Network.HTTP.Client (Manager) import qualified Network.HTTP.Client as L (RequestBody(..)) -- http-client-tls import Network.HTTP.Client.TLS (newTlsManager) @@ -95,13 +96,13 @@ getBs apiplane paths params tok = responseBody <$> req GET url NoReqBody bsRespo -- | 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 =>