{-# LANGUAGE DataKinds #-}
{-# language QuasiQuotes #-}
{-# options_ghc -Wno-unused-imports #-}
module MSAzureAPI.Internal.Common (
APIPlane(..)
, put
, get
, getBs
, getLbs
, post
, postRaw
, postSBMessage
, delete
, run
, withTLS
, (==:)
, tryReq
, Collection
, collectionValue
, collectionNextLink
, Location(..)
, showLocation
, locationDisplayName
, aesonOptions
, say
) where
import Control.Monad.IO.Class (MonadIO(..))
import Data.Proxy (Proxy)
import GHC.Generics (Generic(..))
import Data.List (sort, sortBy, stripPrefix, uncons)
import Data.Maybe (listToMaybe, fromJust, fromMaybe)
import Data.Char (toLower)
import qualified Data.Aeson as A (ToJSON(..), encode, FromJSON(..), genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=), Key, Value(..), camelTo2)
import qualified Data.ByteString as BS (ByteString)
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)
import Network.HTTP.Client (Manager)
import qualified Network.HTTP.Client as L (RequestBody(..))
import Network.HTTP.Client.TLS (newTlsManager)
import Network.OAuth.OAuth2 (OAuth2Token(..))
import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))
import Text.URI (URI, mkURI)
import Network.HTTP.Req (Req, runReq, HttpBody(..), HttpConfig(..), HttpException(..), defaultHttpConfig, req, Option, (=:), GET(..), POST(..), PUT(..), DELETE(..), Url, Scheme(..), urlQ, useHttpsURI, https, (/:), ReqBodyJson(..), NoReqBody(..), oAuth2Bearer, HttpResponse(..), jsonResponse, JsonResponse, lbsResponse, LbsResponse, bsResponse, BsResponse, responseBody)
import Data.Text (Text, pack, unpack)
import UnliftIO (MonadUnliftIO(..))
import UnliftIO.Exception (try)
(==:) :: Text
-> Text
-> Option 'Https
==: :: Text -> Text -> Option 'Https
(==:) = forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
(=:)
getLbs :: APIPlane
-> [Text]
-> Option 'Https -> AccessToken -> Req LBS.ByteString
getLbs :: APIPlane
-> [Text] -> Option 'Https -> AccessToken -> Req ByteString
getLbs APIPlane
apiplane [Text]
paths Option 'Https
params AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok
getBs :: APIPlane
-> [Text]
-> Option 'Https -> AccessToken -> Req BS.ByteString
getBs :: APIPlane
-> [Text] -> Option 'Https -> AccessToken -> Req ByteString
getBs APIPlane
apiplane [Text]
paths Option 'Https
params AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody Proxy BsResponse
bsResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok
withTLS :: MonadIO m =>
(HttpConfig -> Manager -> m b)
-> m b
withTLS :: forall (m :: * -> *) b.
MonadIO m =>
(HttpConfig -> Manager -> m b) -> m b
withTLS HttpConfig -> Manager -> m b
act = do
Manager
mgr <- forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
let
hc :: HttpConfig
hc = HttpConfig
defaultHttpConfig { httpConfigAltManager :: Maybe Manager
httpConfigAltManager = forall a. a -> Maybe a
Just Manager
mgr }
HttpConfig -> Manager -> m b
act HttpConfig
hc Manager
mgr
run :: MonadIO m =>
HttpConfig -> Req a -> m (Either HttpException a)
run :: forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> Req a -> m (Either HttpException a)
run HttpConfig
hc = forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
hc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Req a -> Req (Either HttpException a)
tryReq
tryReq :: Req a -> Req (Either HttpException a)
tryReq :: forall a. Req a -> Req (Either HttpException a)
tryReq = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try
data APIPlane = APManagement
| APData Text
| APServiceBus Text
put :: (A.FromJSON b, A.ToJSON a) =>
APIPlane
-> [Text]
-> Option 'Https
-> a -> AccessToken -> Req b
put :: forall b a.
(FromJSON b, ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
put APIPlane
apiplane [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req PUT
PUT Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok
delete :: (A.FromJSON b, A.ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
delete :: forall b a.
(FromJSON b, ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
delete APIPlane
apiplane [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req DELETE
DELETE Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok
post :: (A.FromJSON b, A.ToJSON a) =>
APIPlane
-> [Text]
-> Option 'Https
-> a
-> AccessToken -> Req b
post :: forall b a.
(FromJSON b, ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
post APIPlane
apiplane [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok
postRaw :: (A.FromJSON b, A.ToJSON a) =>
Text
-> [Text]
-> Option 'Https
-> a -> AccessToken -> Req b
postRaw :: forall b a.
(FromJSON b, ToJSON a) =>
Text -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
postRaw Text
uraw [Text]
paths Option 'Https
params a
bdy AccessToken
atok = do
URI
uriBase <- forall (m :: * -> *). MonadThrow m => Text -> m URI
mkURI Text
uraw
let
auth :: Option 'Https
auth = AccessToken -> Option 'Https
bearerAuth AccessToken
atok
(Url 'Https
u, Option scheme
uparams) = forall a. HasCallStack => Maybe a -> a
fromJust (forall (scheme :: Scheme). URI -> Maybe (Url 'Https, Option scheme)
useHttpsURI URI
uriBase)
url :: Url 'Https
url = Url 'Https
u forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
//: [Text]
paths
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params forall a. Semigroup a => a -> a -> a
<> forall {scheme :: Scheme}. Option scheme
uparams
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
postSBMessage :: (A.FromJSON b, A.ToJSON a) =>
Text
-> [Text]
-> Option 'Https -> a -> AccessToken -> Req b
postSBMessage :: forall b a.
(FromJSON b, ToJSON a) =>
Text -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
postSBMessage Text
servName [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
url (forall a. a -> ReqBodyServiceBusMessage a
ReqBodyServiceBusMessage a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig (Text -> APIPlane
APServiceBus Text
servName) [Text]
paths AccessToken
tok
data ReqBodyServiceBusMessage a = ReqBodyServiceBusMessage a
instance A.ToJSON a => HttpBody (ReqBodyServiceBusMessage a) where
getRequestBody :: ReqBodyServiceBusMessage a -> RequestBody
getRequestBody (ReqBodyServiceBusMessage a
a) = ByteString -> RequestBody
L.RequestBodyLBS (forall a. ToJSON a => a -> ByteString
A.encode a
a)
getRequestContentType :: ReqBodyServiceBusMessage a -> Maybe ByteString
getRequestContentType ReqBodyServiceBusMessage a
_ = forall a. a -> Maybe a
Just ByteString
"application/vnd.microsoft.servicebus.json"
get :: (A.FromJSON b) =>
APIPlane
-> [Text]
-> Option 'Https -> AccessToken -> Req b
get :: forall b.
FromJSON b =>
APIPlane -> [Text] -> Option 'Https -> AccessToken -> Req b
get APIPlane
apiplane [Text]
paths Option 'Https
params AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
where
opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
(Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok
msAzureReqConfig :: APIPlane
-> [Text]
-> AccessToken
-> (Url 'Https, Option 'Https)
msAzureReqConfig :: APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
uriRest AccessToken
atok = (Url 'Https
url, Option 'Https
os)
where
url :: Url 'Https
url = APIPlane -> [Text] -> Url 'Https
apiPlaneBaseURL APIPlane
apiplane [Text]
uriRest
os :: Option 'Https
os = AccessToken -> Option 'Https
bearerAuth AccessToken
atok
apiPlaneBaseURL :: APIPlane
-> [Text]
-> Url 'Https
apiPlaneBaseURL :: APIPlane -> [Text] -> Url 'Https
apiPlaneBaseURL APIPlane
apiplane [Text]
uriRest = (Text -> Url 'Https
https Text
urlBase) forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
//: [Text]
uriRest
where
urlBase :: Text
urlBase = case APIPlane
apiplane of
APIPlane
APManagement -> Text
"management.azure.com"
APData Text
ub -> Text
ub
APServiceBus Text
sn -> Text
sn forall a. Semigroup a => a -> a -> a
<> Text
".servicebus.windows.net"
bearerAuth :: AccessToken -> Option 'Https
bearerAuth :: AccessToken -> Option 'Https
bearerAuth (AccessToken Text
ttok) = ByteString -> Option 'Https
oAuth2Bearer forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS8.pack (Text -> String
unpack Text
ttok)
(//:) :: Url scheme -> [Text] -> Url scheme
//: :: forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
(//:) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
(/:)
showLocation :: Location -> Text
showLocation :: Location -> Text
showLocation = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
data Location =
LNorthEU
| LWestEU
deriving (Location -> Location -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c== :: Location -> Location -> Bool
Eq)
instance Show Location where
show :: Location -> String
show = \case
Location
LNorthEU -> String
"northeu"
Location
LWestEU -> String
"westeu"
instance A.ToJSON Location where
toJSON :: Location -> Value
toJSON = Text -> Value
A.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Text
locationDisplayName
locationDisplayName :: Location -> Text
locationDisplayName :: Location -> Text
locationDisplayName = \case
Location
LNorthEU -> Text
"North Europe"
Location
LWestEU -> Text
"West Europe"
data Collection a = Collection {
forall a. Collection a -> [a]
cValue :: [a]
, forall a. Collection a -> Maybe Text
cNextLink :: Maybe Text
} deriving (Collection a -> Collection a -> Bool
forall a. Eq a => Collection a -> Collection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Collection a -> Collection a -> Bool
$c/= :: forall a. Eq a => Collection a -> Collection a -> Bool
== :: Collection a -> Collection a -> Bool
$c== :: forall a. Eq a => Collection a -> Collection a -> Bool
Eq, Int -> Collection a -> ShowS
forall a. Show a => Int -> Collection a -> ShowS
forall a. Show a => [Collection a] -> ShowS
forall a. Show a => Collection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Collection a] -> ShowS
$cshowList :: forall a. Show a => [Collection a] -> ShowS
show :: Collection a -> String
$cshow :: forall a. Show a => Collection a -> String
showsPrec :: Int -> Collection a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Collection a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Collection a) x -> Collection a
forall a x. Collection a -> Rep (Collection a) x
$cto :: forall a x. Rep (Collection a) x -> Collection a
$cfrom :: forall a x. Collection a -> Rep (Collection a) x
Generic)
instance A.FromJSON a => A.FromJSON (Collection a) where
parseJSON :: Value -> Parser (Collection a)
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
A.genericParseJSON (String -> Options
aesonOptions String
"c")
collectionValue :: Collection a -> [a]
collectionValue :: forall a. Collection a -> [a]
collectionValue = forall a. Collection a -> [a]
cValue
collectionNextLink :: Collection a -> Maybe Text
collectionNextLink :: forall a. Collection a -> Maybe Text
collectionNextLink = forall a. Collection a -> Maybe Text
cNextLink
aesonOptions :: String
-> A.Options
aesonOptions :: String -> Options
aesonOptions String
pfx = Options
A.defaultOptions { fieldLabelModifier :: ShowS
A.fieldLabelModifier = String -> ShowS
recordName String
pfx }
recordName :: String
-> String
-> String
recordName :: String -> ShowS
recordName String
pf String
str = case forall a. [a] -> Maybe (a, [a])
uncons forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [a]
dropPrefix String
pf String
str of
Just (Char
c, String
cs) -> Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
cs
Maybe (Char, String)
_ -> forall a. HasCallStack => String -> a
error String
"record name cannot be empty"
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix :: forall a. Eq a => [a] -> [a] -> [a]
dropPrefix [a]
a [a]
b = forall a. a -> Maybe a -> a
fromMaybe [a]
b forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
a [a]
b
say :: MonadIO m => String -> m ()
say :: forall (m :: * -> *). MonadIO m => String -> m ()
say = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn