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


-- | Simple URI Type, since all the others are obnoxious
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
  = -- TODO: figure out all scopes and hard-code
    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