ms-auth and ms-azure-api new release

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"]

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.

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"
 

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

ms-azure-api/src/MSAzureAPI.hs

@@ -1,6 +1,8 @@
 module MSAzureAPI (
  -- * HTTP request helpers
  tryReq
+ , run
+ , withTLS
  -- * Common types
  -- ** Collection
  , Collection

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

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 =>