Add more flexibility in our ability to specify codeservers (#3081)

* Add explicit types for share host and uri

* Ensure we identify servers correctly

* Remove ability to pass args to auth.login

and remove logic for CodeServers config

* PR feedback: special structure for coderserver URI

* Add port to CodeserverId

unison-cli/src/Unison/Auth/CredentialManager.hs

@@ -11,6 +11,7 @@ where
 import Unison.Auth.CredentialFile
 import Unison.Auth.Types
 import Unison.Prelude
+import Unison.Share.Types (CodeserverId)
 import qualified UnliftIO
 
 -- | A 'CredentialManager' knows how to load, save, and cache credentials.
@@ -21,7 +22,7 @@ import qualified UnliftIO
 newtype CredentialManager = CredentialManager (UnliftIO.MVar Credentials)
 
 -- | Saves credentials to the active profile.
-saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> Host -> Tokens -> m ()
+saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> CodeserverId -> Tokens -> m ()
 saveTokens credManager aud tokens = do
   void . modifyCredentials credManager $ setActiveTokens aud tokens
 
@@ -32,7 +33,7 @@ modifyCredentials (CredentialManager credsVar) f = do
     newCreds <- atomicallyModifyCredentialsFile f
     pure (newCreds, newCreds)
 
-getTokens :: MonadIO m => CredentialManager -> Host -> m (Either CredentialFailure Tokens)
+getTokens :: MonadIO m => CredentialManager -> CodeserverId -> m (Either CredentialFailure Tokens)
 getTokens (CredentialManager credsVar) aud = do
   creds <- UnliftIO.readMVar credsVar
   pure $ getActiveTokens aud creds

unison-cli/src/Unison/Auth/Discovery.hs

@@ -4,19 +4,19 @@ import qualified Data.Aeson as Aeson
 import qualified Data.Text as Text
 import qualified Network.HTTP.Client as HTTP
 import Network.URI
-import qualified Network.URI as URI
 import Unison.Auth.Types
 import Unison.Prelude
+import Unison.Share.Types (CodeserverURI (..), codeserverToURI)
 import qualified UnliftIO
 
-discoveryURI :: Host -> Either CredentialFailure URI
-discoveryURI (Host host) =
-  maybeToEither (InvalidHost (Host host)) (URI.parseURI ("https://" <> Text.unpack host)) <&> \host ->
-    host {uriPath = "/.well-known/openid-configuration"}
+discoveryURI :: CodeserverURI -> URI
+discoveryURI cs =
+  let uri = codeserverToURI cs
+   in uri {uriPath = uriPath uri <> "/.well-known/openid-configuration"}
 
-discoveryForHost :: MonadIO m => HTTP.Manager -> Host -> m (Either CredentialFailure DiscoveryDoc)
-discoveryForHost httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do
-  uri <- UnliftIO.fromEither $ discoveryURI host
+discoveryForCodeserver :: MonadIO m => HTTP.Manager -> CodeserverURI -> m (Either CredentialFailure DiscoveryDoc)
+discoveryForCodeserver httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do
+  let uri = discoveryURI host
   req <- HTTP.requestFromURI uri
   resp <- HTTP.httpLbs req httpClient
   case Aeson.eitherDecode (HTTP.responseBody $ resp) of

unison-cli/src/Unison/Auth/HTTPClient.hs

@@ -1,14 +1,14 @@
-module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient(..)) where
+module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient (..)) where
 
 import qualified Data.Text.Encoding as Text
 import Network.HTTP.Client (Request)
 import qualified Network.HTTP.Client as HTTP
 import qualified Network.HTTP.Client.TLS as HTTP
 import Unison.Auth.CredentialManager (CredentialManager)
 import Unison.Auth.Tokens (TokenProvider, newTokenProvider)
-import Unison.Auth.Types
 import Unison.Codebase.Editor.Command (UCMVersion)
 import Unison.Prelude
+import Unison.Share.Types (codeserverIdFromURI)
 import qualified Unison.Util.HTTP as HTTP
 
 -- | Newtype to delineate HTTP Managers with access-token logic.
@@ -32,7 +32,10 @@ newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do
 -- If a host isn't associated with any credentials auth is omitted.
 authMiddleware :: TokenProvider -> (Request -> IO Request)
 authMiddleware tokenProvider req = do
-  result <- tokenProvider (Host . Text.decodeUtf8 $ HTTP.host req)
-  case result of
-    Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req
+  case (codeserverIdFromURI $ (HTTP.getUri req)) of
     Left _ -> pure req
+    Right codeserverHost -> do
+      result <- tokenProvider codeserverHost
+      case result of
+        Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req
+        Left _ -> pure req

unison-cli/src/Unison/Auth/OAuth.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 
-module Unison.Auth.OAuth (authenticateHost) where
+module Unison.Auth.OAuth (authenticateCodeserver) where
 
 import qualified Crypto.Hash as Crypto
 import Crypto.Random (getRandomBytes)
@@ -18,12 +18,13 @@ import Network.Wai
 import qualified Network.Wai as Wai
 import qualified Network.Wai.Handler.Warp as Warp
 import Unison.Auth.CredentialManager (CredentialManager, saveTokens)
-import Unison.Auth.Discovery (discoveryForHost)
+import Unison.Auth.Discovery (discoveryForCodeserver)
 import Unison.Auth.Types
 import Unison.Codebase.Editor.HandleInput.LoopState (MonadCommand, respond)
 import qualified Unison.Codebase.Editor.Output as Output
 import Unison.Debug
 import Unison.Prelude
+import Unison.Share.Types (CodeserverURI, codeserverIdFromCodeserverURI)
 import qualified UnliftIO
 import qualified Web.Browser as Web
 
@@ -46,10 +47,10 @@ authTransferServer callback req respond =
 
 -- | Direct the user through an authentication flow with the given server and store the
 -- credentials in the provided credential manager.
-authenticateHost :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> Host -> m (Either CredentialFailure ())
-authenticateHost credsManager host = UnliftIO.try @_ @CredentialFailure $ do
+authenticateCodeserver :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> CodeserverURI -> m (Either CredentialFailure ())
+authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialFailure $ do
   httpClient <- liftIO HTTP.getGlobalManager
-  doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForHost httpClient host
+  doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForCodeserver httpClient codeserverURI
   debugM Auth "Discovery Doc" doc
   authResultVar <- UnliftIO.newEmptyMVar @_ @(Either CredentialFailure Tokens)
   -- The redirect_uri depends on the port, so we need to spin up the server first, but
@@ -76,7 +77,8 @@ authenticateHost credsManager host = UnliftIO.try @_ @CredentialFailure $ do
     void . liftIO $ Web.openBrowser (show authorizationKickoff)
     respond . Output.InitiateAuthFlow $ authorizationKickoff
     tokens <- throwCredFailure $ UnliftIO.readMVar authResultVar
-    saveTokens credsManager host tokens
+    let codeserverId = codeserverIdFromCodeserverURI codeserverURI
+    saveTokens credsManager codeserverId tokens
   where
     throwCredFailure :: m (Either CredentialFailure a) -> m a
     throwCredFailure = throwEitherM

unison-cli/src/Unison/Auth/Tokens.hs

@@ -7,6 +7,7 @@ import Unison.Auth.Types
 import Unison.CommandLine.InputPattern (patternName)
 import qualified Unison.CommandLine.InputPatterns as IP
 import Unison.Prelude
+import Unison.Share.Types (CodeserverId)
 import qualified UnliftIO
 import UnliftIO.Exception
 import Web.JWT
@@ -21,9 +22,9 @@ isExpired accessToken = liftIO do
   let expiry = JWT.secondsSinceEpoch expDate
   pure (now >= expiry)
 
--- | Given a 'Host', provide a valid 'AccessToken' for the associated host.
+-- | Given a 'CodeserverId', provide a valid 'AccessToken' for the associated host.
 -- The TokenProvider may automatically refresh access tokens if we have a refresh token.
-type TokenProvider = Host -> IO (Either CredentialFailure AccessToken)
+type TokenProvider = CodeserverId -> IO (Either CredentialFailure AccessToken)
 
 -- | Creates a 'TokenProvider' using the given 'CredentialManager'
 newTokenProvider :: CredentialManager -> TokenProvider
@@ -38,7 +39,7 @@ newTokenProvider manager host = UnliftIO.try @_ @CredentialFailure $ do
     else pure accessToken
 
 -- | Don't yet support automatically refreshing tokens.
-refreshTokens :: MonadIO m => CredentialManager -> Host -> Tokens -> m (Either CredentialFailure Tokens)
+refreshTokens :: MonadIO m => CredentialManager -> CodeserverId -> Tokens -> m (Either CredentialFailure Tokens)
 refreshTokens _manager _host _tokens =
   -- Refreshing tokens is currently unsupported.
   pure (Left (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again."))

unison-cli/src/Unison/Auth/Types.hs

@@ -14,34 +14,34 @@ module Unison.Auth.Types
     PKCEChallenge,
     ProfileName,
     CredentialFailure (..),
-    Host (..),
     getActiveTokens,
     setActiveTokens,
     emptyCredentials,
   )
 where
 
 import Control.Lens hiding ((.=))
-import Data.Aeson (FromJSON (..), FromJSONKey, KeyValue ((.=)), ToJSON (..), ToJSONKey, (.:), (.:?))
+import Data.Aeson (FromJSON (..), KeyValue ((.=)), ToJSON (..), (.:), (.:?))
 import qualified Data.Aeson as Aeson
 import qualified Data.Map as Map
 import qualified Data.Text as Text
 import Data.Time (NominalDiffTime)
 import Network.URI
 import qualified Network.URI as URI
 import Unison.Prelude
+import Unison.Share.Types (CodeserverId, CodeserverURI)
 
 defaultProfileName :: ProfileName
 defaultProfileName = "default"
 
 data CredentialFailure
-  = ReauthRequired Host
+  = ReauthRequired CodeserverId
   | CredentialParseFailure FilePath Text
   | InvalidDiscoveryDocument URI Text
   | InvalidJWT Text
   | RefreshFailure Text
   | InvalidTokenResponse URI Text
-  | InvalidHost Host
+  | InvalidHost CodeserverURI
   deriving stock (Show, Eq)
   deriving anyclass (Exception)
 
@@ -127,27 +127,21 @@ instance Aeson.FromJSON DiscoveryDoc where
 
 type ProfileName = Text
 
--- | The hostname of a server we may authenticate with,
--- e.g. @Host "enlil.unison-lang.org"@
-newtype Host = Host Text
-  deriving stock (Eq, Ord, Show)
-  deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
-
 data Credentials = Credentials
-  { credentials :: Map ProfileName (Map Host Tokens),
+  { credentials :: Map ProfileName (Map CodeserverId Tokens),
     activeProfile :: ProfileName
   }
   deriving (Eq)
 
 emptyCredentials :: Credentials
 emptyCredentials = Credentials mempty defaultProfileName
 
-getActiveTokens :: Host -> Credentials -> Either CredentialFailure Tokens
+getActiveTokens :: CodeserverId -> Credentials -> Either CredentialFailure Tokens
 getActiveTokens host (Credentials {credentials, activeProfile}) =
   maybeToEither (ReauthRequired host) $
     credentials ^? ix activeProfile . ix host
 
-setActiveTokens :: Host -> Tokens -> Credentials -> Credentials
+setActiveTokens :: CodeserverId -> Tokens -> Credentials -> Credentials
 setActiveTokens host tokens creds@(Credentials {credentials, activeProfile}) =
   let newCredMap =
         credentials

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -29,7 +29,6 @@ import Data.Tuple.Extra (uncurry3)
 import qualified Text.Megaparsec as P
 import U.Util.Timing (unsafeTime)
 import qualified Unison.ABT as ABT
-import Unison.Auth.Types (Host (Host))
 import qualified Unison.Builtin as Builtin
 import qualified Unison.Builtin.Decls as DD
 import qualified Unison.Builtin.Terms as Builtin
@@ -1638,14 +1637,7 @@ loop = do
             UpdateBuiltinsI -> notImplemented
             QuitI -> empty
             GistI input -> handleGist input
-            AuthLoginI mayCodebaseServer -> do
-              case mayCodebaseServer of
-                Nothing -> authLogin Nothing
-                Just codeServer -> do
-                  mayHost <- eval $ ConfigLookup ("CodeServers." <> codeServer)
-                  case mayHost of
-                    Nothing -> respond (UnknownCodeServer codeServer)
-                    Just host -> authLogin (Just $ Host host)
+            AuthLoginI -> authLogin
             VersionI -> do
               ucmVersion <- eval UCMVersion
               respond $ PrintVersion ucmVersion

unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs

@@ -1,28 +1,37 @@
 module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where
 
 import Control.Monad.Reader
-import qualified Data.Text as Text
+import Network.URI (URIAuth (..), parseURI)
 import System.IO.Unsafe (unsafePerformIO)
-import Unison.Auth.OAuth
-import Unison.Auth.Types (Host (..))
+import Unison.Auth.OAuth (authenticateCodeserver)
 import Unison.Codebase.Editor.HandleInput.LoopState
 import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success))
 import Unison.Prelude
+import Unison.Share.Types
 import qualified UnliftIO
 import UnliftIO.Environment (lookupEnv)
 
-defaultShareHost :: Host
-defaultShareHost = unsafePerformIO $ do
+-- | This is the URI where the share API is based.
+defaultShareURI :: CodeserverURI
+defaultShareURI = unsafePerformIO $ do
   lookupEnv "UNISON_SHARE_HOST" <&> \case
     -- TODO: swap to production share before release.
-    Nothing -> Host "share-next.us-west-2.unison-lang.org"
-    Just shareHost -> Host (Text.pack shareHost)
-{-# NOINLINE defaultShareHost #-}
+    Nothing ->
+      CodeserverURI
+        { codeserverScheme = "https:",
+          codeserverAuthority = URIAuth {uriUserInfo = "", uriRegName = "share-next.us-west-2.unison-lang.org", uriPort = ""},
+          codeserverPath = "/api"
+        }
+    Just shareHost ->
+      fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do
+        uri <- parseURI shareHost
+        codeserverFromURI uri
+{-# NOINLINE defaultShareURI #-}
 
-authLogin :: UnliftIO.MonadUnliftIO m => Maybe Host -> Action m i v ()
-authLogin mayHost = do
-  let host = fromMaybe defaultShareHost mayHost
+authLogin :: UnliftIO.MonadUnliftIO m => Action m i v ()
+authLogin = do
+  let host = defaultShareURI
   credsMan <- asks credentialManager
-  (Action . lift . lift . lift $ authenticateHost credsMan host) >>= \case
+  (Action . lift . lift . lift $ authenticateCodeserver credsMan host) >>= \case
     Left err -> respond (CredentialFailureMsg err)
     Right () -> respond Success

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -44,8 +44,6 @@ type SourceName = Text -- "foo.u" or "buffer 7"
 
 type PatchPath = Path.Split'
 
-type CodebaseServerName = Text
-
 data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
   deriving (Eq, Ord, Show)
 
@@ -186,7 +184,7 @@ data Input
   | UiI
   | DocsToHtmlI Path' FilePath
   | GistI GistInput
-  | AuthLoginI (Maybe CodebaseServerName)
+  | AuthLoginI
   | VersionI
   deriving (Eq, Show)
 

unison-cli/src/Unison/CommandLine/InputPatterns.hs

@@ -294,23 +294,23 @@ patch =
     I.Visible
     [(Required, patchArg), (Optional, namespaceArg)]
     ( P.lines
-      [ P.wrap $
-        makeExample' patch
-        <> "rewrites any definitions that depend on "
-        <> "definitions with type-preserving edits to use the updated versions of"
-        <> "these dependencies.",
-        "",
-        P.wrapColumn2
-        [ ( makeExample patch  ["<patch>", "[path]"],
-            "applies the given patch"
-            <> "to the given namespace"
-          ),
-          ( makeExample patch ["<patch>"],
-            "applies the given patch"
-            <> "to the current namespace"
-          )
+        [ P.wrap $
+            makeExample' patch
+              <> "rewrites any definitions that depend on "
+              <> "definitions with type-preserving edits to use the updated versions of"
+              <> "these dependencies.",
+          "",
+          P.wrapColumn2
+            [ ( makeExample patch ["<patch>", "[path]"],
+                "applies the given patch"
+                  <> "to the given namespace"
+              ),
+              ( makeExample patch ["<patch>"],
+                "applies the given patch"
+                  <> "to the current namespace"
+              )
+            ]
         ]
-      ]
     )
     ( \case
         patchStr : ws -> first fromString $ do
@@ -2040,20 +2040,15 @@ authLogin =
     "auth.login"
     []
     I.Hidden
-    [(Optional, noCompletions)]
+    []
     ( P.lines
-        [ P.wrap "Obtain an authentication session with Unison Share or a specified codeserver host.",
+        [ P.wrap "Obtain an authentication session with Unison Share.",
           makeExample authLogin []
-            <> "authenticates ucm with Unison Share.",
-          makeExample authLogin ["mycodeserver"]
-            <> "authenticates ucm with the host configured at"
-            <> P.backticked "CodeServers.mycodeserver"
-            <> "in your .unisonConfig"
+            <> "authenticates ucm with Unison Share."
         ]
     )
     ( \case
-        [] -> Right $ Input.AuthLoginI Nothing
-        [codebaseServerName] -> Right . Input.AuthLoginI $ Just (Text.pack codebaseServerName)
+        [] -> Right $ Input.AuthLoginI
         _ -> Left (showPatternHelp authLogin)
     )