module Network.Globus.Types where

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.Encoding (encodeUtf8)
import GHC.Generics (Generic, Rep)
import GHC.TypeLits
import Network.HTTP.Client (Request)
import Network.HTTP.Types (Status, urlEncode)
import Network.URI
import System.FilePath


(/:) :: Uri a -> String -> Uri a
Tagged URI
uri /: :: forall {k} (a :: k). Uri a -> String -> Uri a
/: String
s = URI -> Tagged a URI
forall {k} (s :: k) b. b -> Tagged s b
Tagged (URI -> Tagged a URI) -> URI -> Tagged a URI
forall a b. (a -> b) -> a -> b
$ URI
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 :: forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
k Text
v (Tagged URI
uri) = URI -> Tagged a URI
forall {k} (s :: k) b. b -> Tagged s b
Tagged (URI -> Tagged a URI) -> URI -> Tagged a URI
forall a b. (a -> b) -> a -> b
$ URI
uri{uriQuery = appendQuery k (Just v) uri.uriQuery}


appendQuery :: Text -> Maybe Text -> String -> String
appendQuery :: Text -> Maybe Text -> String -> String
appendQuery Text
k Maybe Text
mv = \case
  String
"" -> String
"?" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
keyValue
  String
"?" -> String
"?" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
keyValue
  String
rest -> String
rest String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"&" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
keyValue
 where
  keyValue :: String
keyValue =
    ByteString -> String
BC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$
      (Bool -> ByteString -> ByteString
urlEncode Bool
True (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
k)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"="
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (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) Maybe Text
mv


renderUri :: Uri a -> Text
renderUri :: forall {k} (a :: k). Uri a -> Text
renderUri (Tagged URI
u) = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
u String
""


-- | Opaque secret identifying the user. Validate on redirect
newtype State = State Text
  deriving newtype (String -> State
(String -> State) -> IsString State
forall a. (String -> a) -> IsString a
$cfromString :: String -> State
fromString :: String -> State
IsString, Maybe State
Value -> Parser [State]
Value -> Parser State
(Value -> Parser State)
-> (Value -> Parser [State]) -> Maybe State -> FromJSON State
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser State
parseJSON :: Value -> Parser State
$cparseJSONList :: Value -> Parser [State]
parseJSONList :: Value -> Parser [State]
$comittedField :: Maybe State
omittedField :: Maybe State
FromJSON, State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq)
  deriving (Int -> State -> String -> String
[State] -> String -> String
State -> String
(Int -> State -> String -> String)
-> (State -> String) -> ([State] -> String -> String) -> Show State
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> State -> String -> String
showsPrec :: Int -> State -> String -> String
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> String -> String
showList :: [State] -> String -> String
Show)


data TokenItem = TokenItem
  { TokenItem -> Scopes
scope :: Scopes
  , TokenItem -> Token 'Access
access_token :: Token Access
  , TokenItem -> Int
expires_in :: Int
  , -- , resource_server :: Text -- "transfer.api.globus.org"
    -- , tokenType :: Text -- "Bearer"
    TokenItem -> State
state :: State
    -- , refresh_token :: Token Refresh
    -- id_token :: Token Identity
  }
  deriving ((forall x. TokenItem -> Rep TokenItem x)
-> (forall x. Rep TokenItem x -> TokenItem) -> Generic TokenItem
forall x. Rep TokenItem x -> TokenItem
forall x. TokenItem -> Rep TokenItem x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TokenItem -> Rep TokenItem x
from :: forall x. TokenItem -> Rep TokenItem x
$cto :: forall x. Rep TokenItem x -> TokenItem
to :: forall x. Rep TokenItem x -> TokenItem
Generic, Maybe TokenItem
Value -> Parser [TokenItem]
Value -> Parser TokenItem
(Value -> Parser TokenItem)
-> (Value -> Parser [TokenItem])
-> Maybe TokenItem
-> FromJSON TokenItem
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser TokenItem
parseJSON :: Value -> Parser TokenItem
$cparseJSONList :: Value -> Parser [TokenItem]
parseJSONList :: Value -> Parser [TokenItem]
$comittedField :: Maybe TokenItem
omittedField :: Maybe TokenItem
FromJSON, TokenItem -> TokenItem -> Bool
(TokenItem -> TokenItem -> Bool)
-> (TokenItem -> TokenItem -> Bool) -> Eq TokenItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenItem -> TokenItem -> Bool
== :: TokenItem -> TokenItem -> Bool
$c/= :: TokenItem -> TokenItem -> Bool
/= :: TokenItem -> TokenItem -> Bool
Eq, Int -> TokenItem -> String -> String
[TokenItem] -> String -> String
TokenItem -> String
(Int -> TokenItem -> String -> String)
-> (TokenItem -> String)
-> ([TokenItem] -> String -> String)
-> Show TokenItem
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TokenItem -> String -> String
showsPrec :: Int -> TokenItem -> String -> String
$cshow :: TokenItem -> String
show :: TokenItem -> String
$cshowList :: [TokenItem] -> String -> String
showList :: [TokenItem] -> String -> String
Show)


data GlobusError
  = InvalidURI String URI
  | Unauthorized Request ByteString
  | ResponseBadStatus Request Status ByteString
  | ResponseBadJSON Request String ByteString
  | MissingScope Scope (NonEmpty TokenItem)
  deriving (Int -> GlobusError -> String -> String
[GlobusError] -> String -> String
GlobusError -> String
(Int -> GlobusError -> String -> String)
-> (GlobusError -> String)
-> ([GlobusError] -> String -> String)
-> Show GlobusError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GlobusError -> String -> String
showsPrec :: Int -> GlobusError -> String -> String
$cshow :: GlobusError -> String
show :: GlobusError -> String
$cshowList :: [GlobusError] -> String -> String
showList :: [GlobusError] -> String -> String
Show, Show GlobusError
Typeable GlobusError
(Typeable GlobusError, Show GlobusError) =>
(GlobusError -> SomeException)
-> (SomeException -> Maybe GlobusError)
-> (GlobusError -> String)
-> Exception GlobusError
SomeException -> Maybe GlobusError
GlobusError -> String
GlobusError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: GlobusError -> SomeException
toException :: GlobusError -> SomeException
$cfromException :: SomeException -> Maybe GlobusError
fromException :: SomeException -> Maybe GlobusError
$cdisplayException :: GlobusError -> String
displayException :: GlobusError -> String
Exception)


type Token a = Tagged a Text
type Id a = Tagged a Text
type Uri a = Tagged a URI


data Token'
  = ClientId
  | ClientSecret
  | Exchange
  | Access


data Id'
  = Submission
  | Request
  | Collection


dataLabelsToJSON :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value
dataLabelsToJSON :: forall a. (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value
dataLabelsToJSON = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions{fieldLabelModifier = dataLabels}


dataLabelsFromJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a
dataLabelsFromJSON :: forall a. (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a
dataLabelsFromJSON = Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions{fieldLabelModifier = dataLabels}


dataLabels :: String -> String
dataLabels :: String -> String
dataLabels String
"data_" = String
"DATA"
dataLabels String
"data_type" = String
"DATA_TYPE"
dataLabels String
f = String
f


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
instance FromJSON (DataType s) where
  parseJSON :: Value -> Parser (DataType s)
parseJSON Value
_ = DataType s -> Parser (DataType s)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataType s
forall (s :: Symbol). DataType s
DataType


data DataKey s = DataKey
  { forall (s :: Symbol). DataKey s -> DataType s
data_type :: DataType s
  , forall (s :: Symbol). DataKey s -> Text
value :: Text
  }
  deriving ((forall x. DataKey s -> Rep (DataKey s) x)
-> (forall x. Rep (DataKey s) x -> DataKey s)
-> Generic (DataKey s)
forall x. Rep (DataKey s) x -> DataKey s
forall x. DataKey s -> Rep (DataKey s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: Symbol) x. Rep (DataKey s) x -> DataKey s
forall (s :: Symbol) x. DataKey s -> Rep (DataKey s) x
$cfrom :: forall (s :: Symbol) x. DataKey s -> Rep (DataKey s) x
from :: forall x. DataKey s -> Rep (DataKey s) x
$cto :: forall (s :: Symbol) x. Rep (DataKey s) x -> DataKey s
to :: forall x. Rep (DataKey s) x -> DataKey s
Generic)
instance FromJSON (DataKey s) where
  parseJSON :: Value -> Parser (DataKey s)
parseJSON = Value -> Parser (DataKey s)
forall a. (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a
dataLabelsFromJSON


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
--   }
--
--
-- 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
    TransferAll
  | Identity ScopeIdentity
  deriving (Int -> Scope -> String -> String
[Scope] -> String -> String
Scope -> String
(Int -> Scope -> String -> String)
-> (Scope -> String) -> ([Scope] -> String -> String) -> Show Scope
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Scope -> String -> String
showsPrec :: Int -> Scope -> String -> String
$cshow :: Scope -> String
show :: Scope -> String
$cshowList :: [Scope] -> String -> String
showList :: [Scope] -> String -> String
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 -> String -> String
[ScopeIdentity] -> String -> String
ScopeIdentity -> String
(Int -> ScopeIdentity -> String -> String)
-> (ScopeIdentity -> String)
-> ([ScopeIdentity] -> String -> String)
-> Show ScopeIdentity
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ScopeIdentity -> String -> String
showsPrec :: Int -> ScopeIdentity -> String -> String
$cshow :: ScopeIdentity -> String
show :: ScopeIdentity -> String
$cshowList :: [ScopeIdentity] -> String -> String
showList :: [ScopeIdentity] -> String -> String
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) -> String -> String
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 -> String -> String
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 -> String -> String
[Scopes] -> String -> String
Scopes -> String
(Int -> Scopes -> String -> String)
-> (Scopes -> String)
-> ([Scopes] -> String -> String)
-> Show Scopes
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Scopes -> String -> String
showsPrec :: Int -> Scopes -> String -> String
$cshow :: Scopes -> String
show :: Scopes -> String
$cshowList :: [Scopes] -> String -> String
showList :: [Scopes] -> String -> String
Show, Scopes -> Scopes -> Bool
(Scopes -> Scopes -> Bool)
-> (Scopes -> Scopes -> Bool) -> Eq Scopes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scopes -> Scopes -> Bool
== :: Scopes -> Scopes -> Bool
$c/= :: Scopes -> Scopes -> Bool
/= :: Scopes -> Scopes -> Bool
Eq)


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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t