module Network.Globus.Types where
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)
import Data.Char (toLower)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy (Proxy (..))
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 GHC.TypeLits
import Network.HTTP.Req as Req
import Network.HTTP.Types (urlEncode)
import Web.HttpApiData (toQueryParam)
type Token a = Tagged a Text
type Id a = Tagged a Text
data Token'
= ClientId
| ClientSecret
| Exchange
| Access
data Id'
= Submission
| Request
| Collection
data DataType (s :: Symbol) = DataType
instance (KnownSymbol s) => ToJSON (DataType s) where
toJSON :: DataType s -> Value
toJSON DataType s
_ = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @s Proxy s
forall {k} (t :: k). Proxy t
Proxy
data Endpoint
= Redirect
| Authorization
| Tokens
| App
data Uri (a :: Endpoint) = Uri
{ forall (a :: Endpoint). Uri a -> Scheme
scheme :: Scheme
, forall (a :: Endpoint). Uri a -> Text
domain :: Text
, forall (a :: Endpoint). Uri a -> [Text]
path :: [Text]
, forall (a :: Endpoint). Uri a -> Query
params :: Query
}
renderUri :: Uri a -> Text
renderUri :: forall (a :: Endpoint). Uri a -> Text
renderUri Uri a
u =
Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
endpoint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query
where
scheme :: Text
scheme =
case Uri a
u.scheme of
Scheme
Http -> Text
"http://"
Scheme
Https -> Text
"https://"
endpoint :: Text
endpoint = Text -> Text
cleanSlash Uri a
u.domain
path :: Text
path = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"/" ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
cleanSlash Uri a
u.path)
query :: Text
query =
case Query -> Text
renderQuery Uri a
u.params of
Text
"" -> Text
""
Text
q -> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q
cleanSlash :: Text -> Text
cleanSlash = (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
instance Show (Uri a) where
show :: Uri a -> String
show = Text -> String
Text.unpack (Text -> String) -> (Uri a -> Text) -> Uri a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri a -> Text
forall (a :: Endpoint). Uri a -> Text
renderUri
newtype Query = Query [(Text, Maybe Text)]
deriving newtype (Semigroup Query
Query
Semigroup Query
-> Query
-> (Query -> Query -> Query)
-> ([Query] -> Query)
-> Monoid Query
[Query] -> Query
Query -> Query -> Query
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Query
mempty :: Query
$cmappend :: Query -> Query -> Query
mappend :: Query -> Query -> Query
$cmconcat :: [Query] -> Query
mconcat :: [Query] -> Query
Monoid, NonEmpty Query -> Query
Query -> Query -> Query
(Query -> Query -> Query)
-> (NonEmpty Query -> Query)
-> (forall b. Integral b => b -> Query -> Query)
-> Semigroup Query
forall b. Integral b => b -> Query -> Query
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Query -> Query -> Query
<> :: Query -> Query -> Query
$csconcat :: NonEmpty Query -> Query
sconcat :: NonEmpty Query -> Query
$cstimes :: forall b. Integral b => b -> Query -> Query
stimes :: forall b. Integral b => b -> Query -> Query
Semigroup)
instance Show Query where
show :: Query -> String
show = Text -> String
Text.unpack (Text -> String) -> (Query -> Text) -> Query -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> Text
renderQuery
instance IsList Query where
type Item Query = (Text, Maybe Text)
fromList :: [Item Query] -> Query
fromList = [(Text, Maybe Text)] -> Query
[Item Query] -> Query
Query
toList :: Query -> [Item Query]
toList (Query [(Text, Maybe Text)]
ps) = [(Text, Maybe Text)]
[Item Query]
ps
instance Req.QueryParam Query where
queryParam :: forall a. ToHttpApiData a => Text -> Maybe a -> Query
queryParam Text
t Maybe a
ma = [(Text, Maybe Text)] -> Query
Query [(Text
t, a -> Text
forall a. ToHttpApiData a => a -> Text
toQueryParam (a -> Text) -> Maybe a -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ma)]
queryParamToList :: Query -> [(Text, Maybe Text)]
queryParamToList (Query [(Text, Maybe Text)]
ps) = [(Text, Maybe Text)]
ps
renderQuery :: Query -> Text
renderQuery :: Query -> Text
renderQuery (Query [(Text, Maybe Text)]
ps) = Text -> [Text] -> Text
Text.intercalate Text
"&" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Maybe Text) -> Text) -> [(Text, Maybe Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe Text) -> Text
toText [(Text, Maybe Text)]
ps
where
toText :: (Text, Maybe Text) -> Text
toText (Text
p, Maybe Text
Nothing) = Text
p
toText (Text
p, Just Text
v) = Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
value Text
v
value :: Text -> Text
value = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> ByteString
urlEncode Bool
True (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
data Scope
=
TransferAll
| Identity ScopeIdentity
deriving (Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> String
(Int -> Scope -> ShowS)
-> (Scope -> String) -> ([Scope] -> ShowS) -> Show Scope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scope -> ShowS
showsPrec :: Int -> Scope -> ShowS
$cshow :: Scope -> String
show :: Scope -> String
$cshowList :: [Scope] -> ShowS
showList :: [Scope] -> ShowS
Show, Scope -> Scope -> Bool
(Scope -> Scope -> Bool) -> (Scope -> Scope -> Bool) -> Eq Scope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
/= :: Scope -> Scope -> Bool
Eq)
data ScopeIdentity
= OpenId
| Email
| Profile
deriving (Int -> ScopeIdentity -> ShowS
[ScopeIdentity] -> ShowS
ScopeIdentity -> String
(Int -> ScopeIdentity -> ShowS)
-> (ScopeIdentity -> String)
-> ([ScopeIdentity] -> ShowS)
-> Show ScopeIdentity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScopeIdentity -> ShowS
showsPrec :: Int -> ScopeIdentity -> ShowS
$cshow :: ScopeIdentity -> String
show :: ScopeIdentity -> String
$cshowList :: [ScopeIdentity] -> ShowS
showList :: [ScopeIdentity] -> ShowS
Show, ScopeIdentity -> ScopeIdentity -> Bool
(ScopeIdentity -> ScopeIdentity -> Bool)
-> (ScopeIdentity -> ScopeIdentity -> Bool) -> Eq ScopeIdentity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScopeIdentity -> ScopeIdentity -> Bool
== :: ScopeIdentity -> ScopeIdentity -> Bool
$c/= :: ScopeIdentity -> ScopeIdentity -> Bool
/= :: ScopeIdentity -> ScopeIdentity -> Bool
Eq)
scopeText :: Scope -> Text
scopeText :: Scope -> Text
scopeText Scope
TransferAll = Text
"urn:globus:auth:scope:transfer.api.globus.org:all"
scopeText (Identity ScopeIdentity
i) = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeIdentity -> String
forall a. Show a => a -> String
show ScopeIdentity
i
scope :: Text -> Maybe Scope
scope :: Text -> Maybe Scope
scope Text
"urn:globus:auth:scope:transfer.api.globus.org:all" = Scope -> Maybe Scope
forall a. a -> Maybe a
Just Scope
TransferAll
scope Text
"email" = Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> Scope -> Maybe Scope
forall a b. (a -> b) -> a -> b
$ ScopeIdentity -> Scope
Identity ScopeIdentity
Email
scope Text
"profile" = Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> Scope -> Maybe Scope
forall a b. (a -> b) -> a -> b
$ ScopeIdentity -> Scope
Identity ScopeIdentity
Profile
scope Text
"openid" = Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> Scope -> Maybe Scope
forall a b. (a -> b) -> a -> b
$ ScopeIdentity -> Scope
Identity ScopeIdentity
OpenId
scope Text
_ = Maybe Scope
forall a. Maybe a
Nothing
instance FromJSON Scope where
parseJSON :: Value -> Parser Scope
parseJSON = String -> (Text -> Parser Scope) -> Value -> Parser Scope
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Scope" ((Text -> Parser Scope) -> Value -> Parser Scope)
-> (Text -> Parser Scope) -> Value -> Parser Scope
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
Parser Scope
-> (Scope -> Parser Scope) -> Maybe Scope -> Parser Scope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Scope
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Scope) -> String -> Parser Scope
forall a b. (a -> b) -> a -> b
$ String
"Invalid scope:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t) Scope -> Parser Scope
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Scope -> Parser Scope) -> Maybe Scope -> Parser Scope
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Scope
scope Text
t
newtype Scopes = Scopes (NonEmpty Scope)
deriving newtype (Int -> Scopes -> ShowS
[Scopes] -> ShowS
Scopes -> String
(Int -> Scopes -> ShowS)
-> (Scopes -> String) -> ([Scopes] -> ShowS) -> Show Scopes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scopes -> ShowS
showsPrec :: Int -> Scopes -> ShowS
$cshow :: Scopes -> String
show :: Scopes -> String
$cshowList :: [Scopes] -> ShowS
showList :: [Scopes] -> ShowS
Show)
instance FromJSON Scopes where
parseJSON :: Value -> Parser Scopes
parseJSON = String -> (Text -> Parser Scopes) -> Value -> Parser Scopes
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Scopes" ((Text -> Parser Scopes) -> Value -> Parser Scopes)
-> (Text -> Parser Scopes) -> Value -> Parser Scopes
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
NonEmpty Text
ts <- Text -> Parser (NonEmpty Text)
forall {f :: * -> *}. MonadFail f => Text -> f (NonEmpty Text)
parseSplitSpace Text
t
NonEmpty Scope
ss <- (Text -> Parser Scope) -> NonEmpty Text -> Parser (NonEmpty Scope)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Value -> Parser Scope
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Scope) -> (Text -> Value) -> Text -> Parser Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String) NonEmpty Text
ts
Scopes -> Parser Scopes
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scopes -> Parser Scopes) -> Scopes -> Parser Scopes
forall a b. (a -> b) -> a -> b
$ NonEmpty Scope -> Scopes
Scopes NonEmpty Scope
ss
where
parseSplitSpace :: Text -> f (NonEmpty Text)
parseSplitSpace Text
t = do
case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
" " Text
t of
(Text
s : [Text]
ss) -> NonEmpty Text -> f (NonEmpty Text)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty Text -> f (NonEmpty Text))
-> NonEmpty Text -> f (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ Text
s Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [Text]
ss
[Text]
_ -> String -> f (NonEmpty Text)
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f (NonEmpty Text)) -> String -> f (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ String
"Scopes split on spaces " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t