globus 0.1.3 → 0.2.0

raw patch · 7 files changed

+317/−198 lines, 7 filesdep +exceptionsdep +filepathdep +http-clientdep −reqPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, filepath, http-client, http-client-tls, network-uri

Dependencies removed: req

API changes (from Hackage documentation)

Files

• globus.cabal +8/−2
• src/Effectful/Globus.hs +28/−13
• src/Network/Globus.hs +1/−3
• src/Network/Globus/Auth.hs +40/−63
• src/Network/Globus/Request.hs +47/−0
• src/Network/Globus/Transfer.hs +43/−53
• src/Network/Globus/Types.hs +150/−64

@@ -5,8 +5,9 @@ -- see: https://github.com/sol/hpack  name:           globus-version:        0.1.3+version:        0.2.0 synopsis:       Globus Data Transfer+description:    Haskell Client for Globus File Transfer API category:       System, Data, Science homepage:       https://github.com/DKISTDC/globus.hs author:         Sean Hess@@ -21,6 +22,7 @@       Effectful.Globus       Network.Globus       Network.Globus.Auth+      Network.Globus.Request       Network.Globus.Transfer       Network.Globus.Types   other-modules:@@ -47,9 +49,13 @@     , base >=4.16.4.0 && <5     , bytestring >=0.11 && <0.13     , effectful >=2.3 && <3+    , exceptions ==0.10.*+    , filepath >=1.5.2 && <1.6     , http-api-data ==0.6.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*     , http-types ==0.12.*-    , req ==3.13.*+    , network-uri ==2.6.*     , tagged ==0.8.*     , text ==2.*   default-language: GHC2021

@@ -13,17 +13,19 @@   , TaskFilters (..)   , TaskList (..)   , module Network.Globus.Types-  , Req.Scheme (..)+  , requireScopeToken   ) where +import Control.Monad.Catch (catch) import Data.List.NonEmpty (NonEmpty) import Data.Tagged import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Error.Static import Network.Globus.Auth import Network.Globus.Transfer-import Network.Globus.Types-import Network.HTTP.Req as Req+import Network.Globus.Types hiding (appendQuery, param)+import Network.HTTP.Client (Manager)   data GlobusClient = GlobusClient@@ -36,7 +38,7 @@   AuthUrl :: Uri Redirect -> NonEmpty Scope -> State -> Globus m (Uri Authorization)   GetUserInfo :: Token OpenId -> Globus m UserInfoResponse   GetAccessTokens :: Token Exchange -> Uri Redirect -> Globus m (NonEmpty TokenItem)-  SubmissionId :: Token Access -> Globus m (Id Submission)+  GetSubmissionId :: Token Access -> Globus m (Id Submission)   Transfer :: Token Access -> TransferRequest -> Globus m TransferResponse   StatusTask :: Token Access -> Id Task -> Globus m Task   StatusTasks :: Token Access -> TaskFilters -> Globus m TaskList@@ -46,22 +48,35 @@   runGlobus-  :: (IOE :> es)+  :: (IOE :> es, Error GlobusError :> es)   => GlobusClient+  -> Manager   -> Eff (Globus : es) a   -> Eff es a-runGlobus g = interpret $ \_ -> \case+runGlobus g mgr = interpret $ \_ -> \case   GetAccessTokens exc red -> do-    liftIO $ fetchAccessTokens g.clientId g.clientSecret red exc+    runGlobusIO $ fetchAccessTokens mgr g.clientId g.clientSecret red exc   GetUserInfo ti -> do-    liftIO $ fetchUserInfo ti+    runGlobusIO $ fetchUserInfo mgr ti   AuthUrl red scopes state -> do     pure $ authorizationUrl g.clientId red scopes state-  SubmissionId access -> do-    liftIO $ fetchSubmissionId access+  GetSubmissionId access -> do+    runGlobusIO $ fetchSubmissionId mgr access   Transfer access request -> do-    liftIO $ sendTransfer access request+    runGlobusIO $ sendTransfer mgr access request   StatusTask access ti -> do-    liftIO $ fetchTask access ti+    runGlobusIO $ fetchTask mgr access ti   StatusTasks access tf -> do-    liftIO $ fetchTasks access tf+    runGlobusIO $ fetchTasks mgr access tf+ where+  onGlobusErr :: (Error GlobusError :> es) => GlobusError -> Eff es a+  onGlobusErr = throwError++  runGlobusIO :: (IOE :> es, Error GlobusError :> es) => IO a -> Eff es a+  runGlobusIO ma = catch (liftIO ma) onGlobusErr+++requireScopeToken :: (Error GlobusError :> es) => Scope -> NonEmpty TokenItem -> Eff es (Token a)+requireScopeToken s tis = do+  Tagged t <- maybe (throwError $ MissingScope s tis) pure $ scopeToken s tis+  pure $ Tagged t

@@ -3,12 +3,10 @@   , module Network.Globus.Transfer   , module Network.Globus.Auth   , Tagged (..)-  , Req.Scheme (..)   ) where  import Data.Tagged (Tagged (..)) import Network.Globus.Auth import Network.Globus.Transfer-import Network.Globus.Types-import Network.HTTP.Req as Req+import Network.Globus.Types hiding (appendQuery, param) 

@@ -1,68 +1,60 @@+{-# LANGUAGE QuasiQuotes #-}+ module Network.Globus.Auth where +import Control.Monad.Catch (MonadCatch, MonadThrow) import Data.Aeson import Data.Aeson.Types+import Data.Function ((&)) import Data.List qualified as L import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.String (IsString) import Data.Tagged import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding (encodeUtf8) import Effectful (MonadIO) import GHC.Generics (Generic)+import Network.Globus.Request as Request import Network.Globus.Types-import Network.HTTP.Req as Req----- | Opaque secret identifying the user. Validate on redirect-newtype State = State Text-  deriving newtype (IsString, FromJSON)-  deriving (Show)+import Network.HTTP.Client (Manager, applyBasicAuth)+import Network.HTTP.Types (Header, methodPost)+import Network.URI.Static (uri)   -- | The end user must visit this url authorizationUrl :: Token ClientId -> Uri Redirect -> NonEmpty Scope -> State -> Uri Authorization authorizationUrl (Tagged cid) red scopes (State st) =   -- TODO: does the auth url need the security token?-  authorizeEndpoint{params = query}- where-  query :: Query-  query =-    "client_id" =: cid-      <> "response_type" =: ("code" :: Text)-      <> "scope" =: Text.intercalate " " (scopeText <$> NE.toList scopes)-      <> "state" =: st-      <> redirectUri red--  authorizeEndpoint :: Uri Authorization-  authorizeEndpoint = Uri Https "auth.globus.org" ["v2", "oauth2", "authorize"] (Query [])+  authEndpoint /: "authorize"+    & param "client_id" cid+    & param "response_type" "code"+    & param "scope" (Text.intercalate " " (scopeText <$> NE.toList scopes))+    & param "state" st+    & redirectUri red  -fetchAccessTokens :: (MonadIO m) => Token ClientId -> Token ClientSecret -> Uri Redirect -> Token Exchange -> m (NonEmpty TokenItem)-fetchAccessTokens (Tagged cid) (Tagged sec) red (Tagged code) = do-  runReq defaultHttpConfig $ do-    res <--      req POST tokenEndpoint NoReqBody jsonResponse $-        "grant_type" =: ("authorization_code" :: Text)-          <> "code" =: code-          <> redirectUri red-          -- TODO: is this the correct basic auth?-          <> basicAuth (encodeUtf8 cid) (encodeUtf8 sec)--    -- liftIO $ print $ responseBody res-    let TokenResponse toks = responseBody res :: TokenResponse-    pure toks+fetchAccessTokens :: (MonadIO m, MonadThrow m, MonadCatch m) => Manager -> Token ClientId -> Token ClientSecret -> Uri Redirect -> Token Exchange -> m (NonEmpty TokenItem)+fetchAccessTokens mgr (Tagged cid) (Tagged sec) red (Tagged code) = do+  req <- Request.request methodPost tokenUri [] ""+  TokenResponse toks <- sendJSON mgr (req & applyBasicAuth (encodeUtf8 cid) (encodeUtf8 sec))+  pure toks  where-  tokenEndpoint :: Req.Url 'Https-  tokenEndpoint = https "auth.globus.org" /: "v2" /: "oauth2" /: "token"+  tokenEndpoint :: Uri Tokens+  tokenEndpoint = Tagged $ [uri|https://auth.globus.org/v2/oauth2/token|] +  tokenUri :: Uri Tokens+  tokenUri =+    tokenEndpoint+      & param "grant_type" "authorization_code"+      & param "code" code+      & redirectUri red -redirectUri :: (QueryParam param) => Uri Redirect -> param-redirectUri red = "redirect_uri" =: renderUri red +redirectUri :: Uri Redirect -> Uri a -> Uri a+redirectUri red = param "redirect_uri" (renderUri red) + -- | fetchAccessTokens returns a non-empty list matching the scopes newtype TokenResponse = TokenResponse (NonEmpty TokenItem)   deriving (Show)@@ -75,19 +67,6 @@     pure $ TokenResponse $ token :| other  -data TokenItem = TokenItem-  { scope :: Scopes-  , access_token :: Token Access-  , expires_in :: Int-  , -- , resource_server :: Text -- "transfer.api.globus.org"-    -- , tokenType :: Text -- "Bearer"-    state :: State-    -- , refresh_token :: Token Refresh-    -- id_token :: Token Identity-  }-  deriving (Generic, FromJSON, Show)-- scopeToken :: Scope -> NonEmpty TokenItem -> Maybe (Token Access) scopeToken s ts = do   item <- L.find (\i -> hasScope i.scope) $ NE.toList ts@@ -97,20 +76,18 @@   -- | You MUST include the OpenId Scope for this to work-fetchUserInfo :: (MonadIO m) => Token OpenId -> m UserInfoResponse-fetchUserInfo to =-  runReq defaultHttpConfig $ do-    res <--      req POST endpoint NoReqBody jsonResponse $-        identityAuth to-    pure $ responseBody res- where-  endpoint :: Req.Url 'Https-  endpoint = https "auth.globus.org" /: "v2" /: "oauth2" /: "userinfo"+fetchUserInfo :: (MonadIO m, MonadCatch m, MonadThrow m) => Manager -> Token OpenId -> m UserInfoResponse+fetchUserInfo mgr to = do+  req <- Request.request methodPost (authEndpoint /: "userinfo") [identityAuth to] ""+  sendJSON mgr req  -identityAuth :: Token OpenId -> Option Https-identityAuth (Tagged oid) = oAuth2Bearer (encodeUtf8 oid)+authEndpoint :: Uri Authorization+authEndpoint = Tagged $ [uri|https://auth.globus.org/v2/oauth2|]+++identityAuth :: Token OpenId -> Header+identityAuth = oAuth2Bearer   --  where

@@ -0,0 +1,47 @@+module Network.Globus.Request where++import Control.Monad (unless, when)+import Control.Monad.Catch (MonadCatch, MonadThrow, SomeException, catch, throwM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode)+import Data.Tagged+import Data.Text.Encoding (encodeUtf8)+import Network.Globus.Types+import Network.HTTP.Client as Http+import Network.HTTP.Types+++request :: (MonadThrow m, MonadCatch m) => Method -> Uri a -> [Header] -> RequestBody -> m Http.Request+request m (Tagged u) hs body = do+  req <- catch (Http.requestFromURI u) invalidUri+  pure $ req{method = m, requestHeaders = hs, requestBody = body}+ where+  invalidUri :: (MonadThrow m) => SomeException -> m a+  invalidUri e = throwM $ InvalidURI (show e) u+++get :: (MonadThrow m, MonadCatch m) => Uri a -> [Header] -> m Http.Request+get u hs = request methodGet u hs ""+++post :: (MonadThrow m, MonadCatch m, ToJSON b) => Uri a -> [Header] -> b -> m Http.Request+post u hs b = request methodPost u hs (RequestBodyLBS $ encode b)+++sendJSON :: (MonadIO m, FromJSON a, MonadThrow m) => Manager -> Request -> m a+sendJSON mgr req = do+  res <- liftIO $ Http.httpLbs req mgr++  when (responseStatus res == unauthorized401) $ do+    throwM $ Unauthorized req (responseBody res)++  unless (responseStatus res == status200) $ do+    throwM $ ResponseBadStatus req (responseStatus res) (responseBody res)++  case eitherDecode (responseBody res) of+    Left e -> throwM $ ResponseBadJSON req (show e) (responseBody res)+    Right a -> pure a+++oAuth2Bearer :: Token a -> Header+oAuth2Bearer (Tagged tok) = ("Authorization", "Bearer " <> encodeUtf8 tok)

@@ -1,51 +1,55 @@+{-# LANGUAGE QuasiQuotes #-}+ module Network.Globus.Transfer where +import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.IO.Class import Data.Aeson import Data.Char (toUpper)+import Data.Function ((&)) import Data.Tagged-import Data.Text (Text, pack)+import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8)-import Effectful (MonadIO)-import GHC.Generics (Generic, Rep)+import GHC.Generics (Generic)+import Network.Globus.Request as Request import Network.Globus.Types-import Network.HTTP.Req as Req+import Network.HTTP.Client as Http+import Network.HTTP.Types (Header)+import Network.URI+import Network.URI.Static (uri)  --- -----------------------------------------+-------------------------------------------- -- API--- -----------------------------------------+-------------------------------------------- -fetchSubmissionId :: (MonadIO m) => Token Access -> m (Id Submission)-fetchSubmissionId access =-  runReq defaultHttpConfig $ do-    res <- req GET (transferEndpoint /: "submission_id") NoReqBody jsonResponse (transferAuth access)-    let idRes = responseBody res :: IdResponse-    pure $ Tagged idRes.value+fetchSubmissionId :: (MonadThrow m, MonadCatch m, MonadIO m) => Manager -> Token Access -> m (Id Submission)+fetchSubmissionId mgr access = do+  req <- Request.get (transferEndpoint /: "submission_id") [transferAuth access]+  DataKey _ s <- sendJSON mgr req+  pure $ Tagged s  -transferAuth :: Token Access -> Option Https-transferAuth (Tagged access) = oAuth2Bearer (encodeUtf8 access)+transferAuth :: Token Access -> Header+transferAuth (Tagged access) = ("Authorization", "Bearer " <> encodeUtf8 access)  -transferEndpoint :: Req.Url 'Https-transferEndpoint = https "transfer.api.globus.org" /: "v0.10"+transferEndpoint :: Uri a+transferEndpoint = Tagged $ [uri|https://transfer.api.globus.org/v0.10|]  -sendTransfer :: (MonadIO m) => Token Access -> TransferRequest -> m TransferResponse-sendTransfer access request =-  runReq defaultHttpConfig $ do-    res <- req POST (transferEndpoint /: "transfer") (ReqBodyJson request) jsonResponse (transferAuth access)-    let tr = responseBody res :: TransferResponse-    pure tr+sendTransfer :: (MonadIO m, MonadThrow m, MonadCatch m) => Manager -> Token Access -> TransferRequest -> m TransferResponse+sendTransfer mgr access treq = do+  req <- Request.post (transferEndpoint /: "transfer") [transferAuth access] treq+  sendJSON mgr req   -- https://docs.globus.org/api/transfer/task/#get_task_by_id-fetchTask :: (MonadIO m) => Token Access -> Id Task -> m Task-fetchTask access (Tagged ti) = do-  runReq defaultHttpConfig $ do-    res <- req GET (transferEndpoint /: "task" /: ti) NoReqBody jsonResponse (transferAuth access)-    pure (responseBody res)+fetchTask :: (MonadIO m, MonadThrow m, MonadCatch m) => Manager -> Token Access -> Id Task -> m Task+fetchTask mgr access (Tagged ti) = do+  req <- Request.get (transferEndpoint /: "task" /: T.unpack ti) [transferAuth access]+  sendJSON mgr req   newtype TaskFilters = TaskFilters@@ -58,23 +62,19 @@   tf1 <> tf2 = TaskFilters{status = tf1.status <> tf2.status}  -fetchTasks :: (MonadIO m) => Token Access -> TaskFilters -> m TaskList-fetchTasks access tf = do-  runReq defaultHttpConfig $ do-    res <--      req GET (transferEndpoint /: "task_list") NoReqBody jsonResponse $-        transferAuth access-          <> "filter" =: status tf.status-    pure (responseBody res)+fetchTasks :: (MonadIO m, MonadThrow m, MonadCatch m) => Manager -> Token Access -> TaskFilters -> m TaskList+fetchTasks mgr access tf = do+  req <- Request.get (transferEndpoint /: "task_list" & param "filter" (status tf.status)) [transferAuth access]+  sendJSON mgr req  where   status :: [TaskStatus] -> Text   status [] = ""-  status ss = "status:" <> T.intercalate "," (map (T.toUpper . pack . show) ss)+  status ss = "status:" <> T.intercalate "," (fmap (T.toUpper . T.pack . show) ss)  -activityUrl :: Id Task -> Uri App+activityUrl :: Id Task -> Tagged App URI activityUrl (Tagged t) =-  Uri Https "app.globus.org" ["activity", t] (Query [])+  Tagged [uri|https://app.globus.org/activity|] /: T.unpack t   taskPercentComplete :: Task -> Float@@ -134,7 +134,7 @@   instance FromJSON TaskStatus where-  parseJSON = genericParseJSON defaultOptions{constructorTagModifier = map toUpper}+  parseJSON = genericParseJSON defaultOptions{constructorTagModifier = fmap toUpper}   -- -----------------------------------------@@ -161,13 +161,13 @@  data TransferResponse = TransferResponse   { task_id :: Id Task-  , submission_id :: Token Submission+  , submission_id :: Id Submission   , -- , code :: TransferCode -- Accepted, Duplicate     message :: Text   , resource :: Text   , request_id :: Token Request   }-  deriving (Generic, FromJSON, Show)+  deriving (Generic, FromJSON)   -- https://docs.globus.org/api/transfer/task_submit/#transfer_and_delete_documents@@ -190,7 +190,7 @@   instance ToJSON TransferRequest where-  toJSON = dataLabelsJson+  toJSON = dataLabelsToJSON   -- https://docs.globus.org/api/transfer/task_submit/#transfer_item_fields@@ -212,7 +212,7 @@   instance ToJSON TransferItem where-  toJSON = dataLabelsJson+  toJSON = dataLabelsToJSON   -- newtype FilterRule = FilterRule@@ -237,13 +237,3 @@     toInt SyncSize = 1     toInt SyncTimestamp = 2     toInt SyncChecksum = 3---dataLabelsJson :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value-dataLabelsJson = genericToJSON defaultOptions{fieldLabelModifier = dataLabels}---dataLabels :: String -> String-dataLabels "data_" = "DATA"-dataLabels "data_type" = "DATA_TYPE"-dataLabels f = f

@@ -1,22 +1,86 @@ module Network.Globus.Types where -import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)+import Control.Monad.Catch (Exception)+import Data.Aeson+import Data.Aeson.Types (Parser)+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy (ByteString) import Data.Char (toLower) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy (Proxy (..))+import Data.String (IsString (..)) import Data.Tagged import Data.Text (Text, pack, splitOn, unpack)-import Data.Text qualified as Text-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import GHC.IsList (IsList (..))+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics (Generic, Rep) import GHC.TypeLits-import Network.HTTP.Req as Req-import Network.HTTP.Types (urlEncode)-import Web.HttpApiData (toQueryParam)+import Network.HTTP.Client (Request)+import Network.HTTP.Types (Status, urlEncode)+import Network.URI+import System.FilePath  +(/:) :: Uri a -> String -> Uri a+Tagged uri /: s = Tagged $ uri{uriPath = uri.uriPath </> s}+infixl 5 /:+++-- (?:) :: Uri a -> QueryItem -> Uri a+-- Tagged uri ?: (qk, mqv) =+--  where++param :: Text -> Text -> Uri a -> Uri a+param k v (Tagged uri) = Tagged $ uri{uriQuery = appendQuery k (Just v) uri.uriQuery}+++appendQuery :: Text -> Maybe Text -> String -> String+appendQuery k mv = \case+  "" -> "?" <> keyValue+  "?" -> "?" <> keyValue+  rest -> rest <> "&" <> keyValue+ where+  keyValue =+    BC.unpack $+      (urlEncode True $ encodeUtf8 k)+        <> "="+        <> maybe "" (urlEncode True . encodeUtf8) mv+++renderUri :: Uri a -> Text+renderUri (Tagged u) = pack $ uriToString id u ""+++-- | Opaque secret identifying the user. Validate on redirect+newtype State = State Text+  deriving newtype (IsString, FromJSON, Eq)+  deriving (Show)+++data TokenItem = TokenItem+  { scope :: Scopes+  , access_token :: Token Access+  , expires_in :: Int+  , -- , resource_server :: Text -- "transfer.api.globus.org"+    -- , tokenType :: Text -- "Bearer"+    state :: State+    -- , refresh_token :: Token Refresh+    -- id_token :: Token Identity+  }+  deriving (Generic, FromJSON, Eq, Show)+++data GlobusError+  = InvalidURI String URI+  | Unauthorized Request ByteString+  | ResponseBadStatus Request Status ByteString+  | ResponseBadJSON Request String ByteString+  | MissingScope Scope (NonEmpty TokenItem)+  deriving (Show, Exception)++ type Token a = Tagged a Text type Id a = Tagged a Text+type Uri a = Tagged a URI   data Token'@@ -32,77 +96,99 @@   | Collection  -data DataType (s :: Symbol) = DataType---instance (KnownSymbol s) => ToJSON (DataType s) where-  toJSON _ = String $ pack $ symbolVal @s Proxy---data Endpoint-  = Redirect-  | Authorization-  | Tokens-  | App----- | Simple URI Type, since all the others are obnoxious-data Uri (a :: Endpoint) = Uri-  { scheme :: Scheme-  , domain :: Text-  , path :: [Text]-  , params :: Query-  }+dataLabelsToJSON :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value+dataLabelsToJSON = genericToJSON defaultOptions{fieldLabelModifier = dataLabels}  -renderUri :: Uri a -> Text-renderUri u =-  scheme <> endpoint <> path <> query- where-  scheme =-    case u.scheme of-      Http -> "http://"-      Https -> "https://"-  endpoint = cleanSlash u.domain-  path = "/" <> Text.intercalate "/" (map cleanSlash u.path)-  query =-    case renderQuery u.params of-      "" -> ""-      q -> "?" <> q-  cleanSlash = Text.dropWhileEnd (== '/') . Text.dropWhile (== '/')+dataLabelsFromJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a+dataLabelsFromJSON = genericParseJSON defaultOptions{fieldLabelModifier = dataLabels}  -instance Show (Uri a) where-  show = Text.unpack . renderUri+dataLabels :: String -> String+dataLabels "data_" = "DATA"+dataLabels "data_type" = "DATA_TYPE"+dataLabels f = f  -newtype Query = Query [(Text, Maybe Text)]-  deriving newtype (Monoid, Semigroup)+data DataType (s :: Symbol) = DataType  -instance Show Query where-  show = Text.unpack . renderQuery+instance (KnownSymbol s) => ToJSON (DataType s) where+  toJSON _ = String $ pack $ symbolVal @s Proxy+instance FromJSON (DataType s) where+  parseJSON _ = pure DataType  -instance IsList Query where-  type Item Query = (Text, Maybe Text)-  fromList = Query-  toList (Query ps) = ps+data DataKey s = DataKey+  { data_type :: DataType s+  , value :: Text+  }+  deriving (Generic)+instance FromJSON (DataKey s) where+  parseJSON = dataLabelsFromJSON  -instance Req.QueryParam Query where-  queryParam t ma = Query [(t, toQueryParam <$> ma)]-  queryParamToList (Query ps) = ps+data Endpoint+  = Redirect+  | Authorization+  | Tokens+  | App  -renderQuery :: Query -> Text-renderQuery (Query ps) = Text.intercalate "&" $ map toText ps- where-  toText (p, Nothing) = p-  toText (p, Just v) = p <> "=" <> value v--  value = decodeUtf8 . urlEncode True . encodeUtf8+-- -- | Simple URI Type, since all the others are obnoxious+-- data Uri (a :: Endpoint) = Uri+--   { scheme :: Scheme+--   , domain :: Text+--   , path :: [Text]+--   , params :: Query+--   }+--+--+-- renderUri :: Uri a -> Text+-- renderUri u =+--   scheme <> endpoint <> path <> query+--  where+--   scheme =+--     case u.scheme of+--       Http -> "http://"+--       Https -> "https://"+--   endpoint = cleanSlash u.domain+--   path = "/" <> Text.intercalate "/" (map cleanSlash u.path)+--   query =+--     case renderQuery u.params of+--       "" -> ""+--       q -> "?" <> q+--   cleanSlash = Text.dropWhileEnd (== '/') . Text.dropWhile (== '/')+--+--+-- instance Show (Uri a) where+--   show = Text.unpack . renderUri +-- newtype Query = Query [(Text, Maybe Text)]+--   deriving newtype (Monoid, Semigroup)+--+--+-- instance Show Query where+--   show = Text.unpack . renderQuery+--+--+-- instance IsList Query where+--   type Item Query = (Text, Maybe Text)+--   fromList = Query+--   toList (Query ps) = ps+--+--+-- -- instance Req.QueryParam Query where+-- --   queryParam t ma = Query [(t, toQueryParam <$> ma)]+-- --   queryParamToList (Query ps) = ps+--+-- renderQuery :: Query -> Text+-- renderQuery (Query ps) = Text.intercalate "&" $ map toText ps+--  where+--   toText (p, Nothing) = p+--   toText (p, Just v) = p <> "=" <> value v+--+--   value = decodeUtf8 . urlEncode True . encodeUtf8  data Scope   = -- TODO: figure out all scopes and hard-code@@ -137,7 +223,7 @@   newtype Scopes = Scopes (NonEmpty Scope)-  deriving newtype (Show)+  deriving newtype (Show, Eq)   instance FromJSON Scopes where