{-# LANGUAGE DataKinds #-}
{-# options_ghc -Wno-unused-imports #-}
module MSGraphAPI.Internal.Common (
put
, get
, getLbs
, post
, run
, runReq
, tryReq
, withTLS
, Collection(..)
, aesonOptions
) 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, fromMaybe)
import Data.Char (toLower)
import qualified Data.Aeson as A (ToJSON(..), 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.OAuth.OAuth2 (OAuth2Token(..))
import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (newTlsManager)
import Text.URI (URI, mkURI)
import Network.HTTP.Req (Req, runReq, HttpException(..), HttpConfig(..), defaultHttpConfig, req, Option, (=:), GET(..), POST(..), PUT(..), Url, Scheme(..), 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)
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
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
put :: (A.FromJSON b, A.ToJSON a) =>
[Text]
-> Option 'Https -> a -> AccessToken -> Req b
put :: forall b a.
(FromJSON b, ToJSON a) =>
[Text] -> Option 'Https -> a -> AccessToken -> Req b
put [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) = AccessToken -> [Text] -> (Url 'Https, Option 'Https)
msGraphReqConfig AccessToken
tok [Text]
paths
post :: (A.ToJSON a, A.FromJSON b) =>
[Text]
-> Option 'Https
-> a
-> AccessToken
-> Req b
post :: forall a b.
(ToJSON a, FromJSON b) =>
[Text] -> Option 'Https -> a -> AccessToken -> Req b
post [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) = AccessToken -> [Text] -> (Url 'Https, Option 'Https)
msGraphReqConfig AccessToken
tok [Text]
paths
get :: A.FromJSON a =>
[Text]
-> Option 'Https
-> AccessToken
-> Req a
get :: forall a.
FromJSON a =>
[Text] -> Option 'Https -> AccessToken -> Req a
get [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) = AccessToken -> [Text] -> (Url 'Https, Option 'Https)
msGraphReqConfig AccessToken
tok [Text]
paths
getLbs :: [Text]
-> Option 'Https
-> AccessToken -> Req LBS.ByteString
getLbs :: [Text] -> Option 'Https -> AccessToken -> Req ByteString
getLbs [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) = AccessToken -> [Text] -> (Url 'Https, Option 'Https)
msGraphReqConfig AccessToken
tok [Text]
paths
msGraphReqConfig :: AccessToken -> [Text] -> (Url 'Https, Option 'Https)
msGraphReqConfig :: AccessToken -> [Text] -> (Url 'Https, Option 'Https)
msGraphReqConfig (AccessToken Text
ttok) [Text]
uriRest = (Url 'Https
url, Option 'Https
os)
where
url :: Url 'Https
url = (Text -> Url 'Https
https Text
"graph.microsoft.com" forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"v1.0") forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
//: [Text]
uriRest
os :: Option 'Https
os = 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
(/:)
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.ToJSON a => A.ToJSON (Collection a)
instance A.FromJSON a => A.FromJSON (Collection a) where
parseJSON :: Value -> Parser (Collection a)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Collection" forall a b. (a -> b) -> a -> b
$ \Object
o -> forall a. [a] -> Maybe Text -> Collection a
Collection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"value" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Key
"@odata.nextLink"
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