module Unison.Auth.Discovery where

import Data.Aeson qualified as Aeson
import Data.Text qualified as Text
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Client.TLS qualified as HTTP
import Network.URI
import Unison.Auth.Types
import Unison.Prelude
import Unison.Share.Types (CodeserverURI (..), codeserverToURI)
import UnliftIO qualified

discoveryURIForCodeserver :: CodeserverURI -> URI
discoveryURIForCodeserver :: CodeserverURI -> URI
discoveryURIForCodeserver CodeserverURI
cs =
  let uri :: URI
uri = CodeserverURI -> URI
codeserverToURI CodeserverURI
cs
   in URI
uri {uriPath = uriPath uri <> "/.well-known/openid-configuration"}

fetchDiscoveryDoc :: (MonadIO m) => URI -> m (Either CredentialFailure DiscoveryDoc)
fetchDiscoveryDoc :: forall (m :: * -> *).
MonadIO m =>
URI -> m (Either CredentialFailure DiscoveryDoc)
fetchDiscoveryDoc URI
discoveryURI = IO (Either CredentialFailure DiscoveryDoc)
-> m (Either CredentialFailure DiscoveryDoc)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either CredentialFailure DiscoveryDoc)
 -> m (Either CredentialFailure DiscoveryDoc))
-> (IO DiscoveryDoc -> IO (Either CredentialFailure DiscoveryDoc))
-> IO DiscoveryDoc
-> m (Either CredentialFailure DiscoveryDoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try @_ @CredentialFailure (IO DiscoveryDoc -> m (Either CredentialFailure DiscoveryDoc))
-> IO DiscoveryDoc -> m (Either CredentialFailure DiscoveryDoc)
forall a b. (a -> b) -> a -> b
$ do
  unauthenticatedHttpClient <- IO Manager
HTTP.getGlobalManager
  req <- HTTP.requestFromURI discoveryURI
  resp <- HTTP.httpLbs req unauthenticatedHttpClient
  case Aeson.eitherDecode (HTTP.responseBody $ resp) of
    Left String
err -> CredentialFailure -> IO DiscoveryDoc
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (CredentialFailure -> IO DiscoveryDoc)
-> CredentialFailure -> IO DiscoveryDoc
forall a b. (a -> b) -> a -> b
$ URI -> Text -> CredentialFailure
InvalidDiscoveryDocument URI
discoveryURI (String -> Text
Text.pack String
err)
    Right DiscoveryDoc
doc -> DiscoveryDoc -> IO DiscoveryDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DiscoveryDoc
doc