{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}

-- | This module contains Share API calls related to projects, wrapped in the Cli monad.
--
-- Here, we also validate inputs from Share that the API itself does not. For example, in the API,
-- a project name is just a Text. But because our client requires a richer structure for project names, we try parsing
-- them into a ProjectName, and fail right away if parsing fails.
module Unison.Cli.Share.Projects
  ( -- * API types
    RemoteProject (..),
    RemoteProjectBranch (..),

    -- * API functions
    getProjectById,
    getProjectByName,
    getProjectByName',
    createProject,
    GetProjectBranchResponse (..),
    IncludeSquashedHead (..),
    getProjectBranchById,
    getProjectBranchByName,
    getProjectBranchByName',
    createProjectBranch,
    SetProjectBranchHeadResponse (..),
    setProjectBranchHead,

    -- * Temporary special hard-coded base url
    hardCodedBaseUrl,
    hardCodedUri,
  )
where

import Control.Monad.Reader (ask)
import Data.Proxy
import Network.HTTP.Client qualified as Http.Client
import Network.URI (URI)
import Network.URI qualified as URI
import Servant.API ((:<|>) (..), (:>))
import Servant.Client
import Servant.Client qualified as Servant
import U.Codebase.Sqlite.DbId (RemoteProjectBranchId (..), RemoteProjectId (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Auth.HTTPClient qualified as Auth
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.Share.Projects.Types (RemoteProject (..), RemoteProjectBranch (..))
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Hash32 (Hash32)
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Share.API.Projects qualified as Share.API
import Unison.Share.Codeserver (defaultCodeserver)
import Unison.Share.Types (codeserverBaseURL)

-- | Get a project by id.
--
-- On success, update the `remote_project` table.
getProjectById :: RemoteProjectId -> Cli (Maybe RemoteProject)
getProjectById :: RemoteProjectId -> Cli (Maybe RemoteProject)
getProjectById (RemoteProjectId Text
projectId) = do
  GetProjectResponse
response <- ClientM GetProjectResponse
-> Cli (Either ClientError GetProjectResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (Maybe Text -> Maybe Text -> ClientM GetProjectResponse
getProject0 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
projectId) Maybe Text
forall a. Maybe a
Nothing) Cli (Either ClientError GetProjectResponse)
-> (Cli (Either ClientError GetProjectResponse)
    -> Cli GetProjectResponse)
-> Cli GetProjectResponse
forall a b. a -> (a -> b) -> b
& (ClientError -> Cli GetProjectResponse)
-> Cli (Either ClientError GetProjectResponse)
-> Cli GetProjectResponse
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM ClientError -> Cli GetProjectResponse
forall void. ClientError -> Cli void
servantClientError
  GetProjectResponse -> Cli (Maybe RemoteProject)
onGetProjectResponse GetProjectResponse
response

-- | Get a project by name.
--
-- On success, update the `remote_project` table.
getProjectByName :: ProjectName -> Cli (Maybe RemoteProject)
getProjectByName :: ProjectName -> Cli (Maybe RemoteProject)
getProjectByName ProjectName
projectName =
  ProjectName -> Cli (Either ClientError (Maybe RemoteProject))
getProjectByName' ProjectName
projectName Cli (Either ClientError (Maybe RemoteProject))
-> (Cli (Either ClientError (Maybe RemoteProject))
    -> Cli (Maybe RemoteProject))
-> Cli (Maybe RemoteProject)
forall a b. a -> (a -> b) -> b
& (ClientError -> Cli (Maybe RemoteProject))
-> Cli (Either ClientError (Maybe RemoteProject))
-> Cli (Maybe RemoteProject)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM ClientError -> Cli (Maybe RemoteProject)
forall void. ClientError -> Cli void
servantClientError

-- | Variant of 'getProjectByName' that returns servant client errors.
getProjectByName' :: ProjectName -> Cli (Either Servant.ClientError (Maybe RemoteProject))
getProjectByName' :: ProjectName -> Cli (Either ClientError (Maybe RemoteProject))
getProjectByName' ProjectName
projectName = do
  ClientM GetProjectResponse
-> Cli (Either ClientError GetProjectResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (Maybe Text -> Maybe Text -> ClientM GetProjectResponse
getProject0 Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (forall target source. From source target => source -> target
into @Text ProjectName
projectName))) Cli (Either ClientError GetProjectResponse)
-> (Either ClientError GetProjectResponse
    -> Cli (Either ClientError (Maybe RemoteProject)))
-> Cli (Either ClientError (Maybe RemoteProject))
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ClientError
err -> Either ClientError (Maybe RemoteProject)
-> Cli (Either ClientError (Maybe RemoteProject))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientError -> Either ClientError (Maybe RemoteProject)
forall a b. a -> Either a b
Left ClientError
err)
    Right GetProjectResponse
response -> Maybe RemoteProject -> Either ClientError (Maybe RemoteProject)
forall a b. b -> Either a b
Right (Maybe RemoteProject -> Either ClientError (Maybe RemoteProject))
-> Cli (Maybe RemoteProject)
-> Cli (Either ClientError (Maybe RemoteProject))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetProjectResponse -> Cli (Maybe RemoteProject)
onGetProjectResponse GetProjectResponse
response

-- | Create a new project. Kinda weird: returns `Nothing` if the user handle part of the project doesn't exist.
--
-- On success, update the `remote_project` table.
createProject :: ProjectName -> Cli (Maybe RemoteProject)
createProject :: ProjectName -> Cli (Maybe RemoteProject)
createProject ProjectName
projectName = do
  let request :: CreateProjectRequest
request = Share.API.CreateProjectRequest {$sel:projectName:CreateProjectRequest :: Text
projectName = forall target source. From source target => source -> target
into @Text ProjectName
projectName}
  ClientM CreateProjectResponse
-> Cli (Either ClientError CreateProjectResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (CreateProjectRequest -> ClientM CreateProjectResponse
createProject0 CreateProjectRequest
request) Cli (Either ClientError CreateProjectResponse)
-> (Either ClientError CreateProjectResponse
    -> Cli (Maybe RemoteProject))
-> Cli (Maybe RemoteProject)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ClientError
err -> ClientError -> Cli (Maybe RemoteProject)
forall void. ClientError -> Cli void
servantClientError ClientError
err
    Right (Share.API.CreateProjectResponseNotFound {}) -> Maybe RemoteProject -> Cli (Maybe RemoteProject)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteProject
forall a. Maybe a
Nothing
    Right (Share.API.CreateProjectResponseUnauthorized Unauthorized
x) -> Unauthorized -> Cli (Maybe RemoteProject)
forall void. Unauthorized -> Cli void
unauthorized Unauthorized
x
    Right (Share.API.CreateProjectResponseSuccess Project
project) -> RemoteProject -> Maybe RemoteProject
forall a. a -> Maybe a
Just (RemoteProject -> Maybe RemoteProject)
-> Cli RemoteProject -> Cli (Maybe RemoteProject)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Project -> Cli RemoteProject
onGotProject Project
project

data GetProjectBranchResponse
  = GetProjectBranchResponseBranchNotFound
  | GetProjectBranchResponseProjectNotFound
  | GetProjectBranchResponseSuccess !RemoteProjectBranch

data IncludeSquashedHead
  = IncludeSquashedHead
  | NoSquashedHead
  deriving stock (Int -> IncludeSquashedHead -> ShowS
[IncludeSquashedHead] -> ShowS
IncludeSquashedHead -> [Char]
(Int -> IncludeSquashedHead -> ShowS)
-> (IncludeSquashedHead -> [Char])
-> ([IncludeSquashedHead] -> ShowS)
-> Show IncludeSquashedHead
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncludeSquashedHead -> ShowS
showsPrec :: Int -> IncludeSquashedHead -> ShowS
$cshow :: IncludeSquashedHead -> [Char]
show :: IncludeSquashedHead -> [Char]
$cshowList :: [IncludeSquashedHead] -> ShowS
showList :: [IncludeSquashedHead] -> ShowS
Show, IncludeSquashedHead -> IncludeSquashedHead -> Bool
(IncludeSquashedHead -> IncludeSquashedHead -> Bool)
-> (IncludeSquashedHead -> IncludeSquashedHead -> Bool)
-> Eq IncludeSquashedHead
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncludeSquashedHead -> IncludeSquashedHead -> Bool
== :: IncludeSquashedHead -> IncludeSquashedHead -> Bool
$c/= :: IncludeSquashedHead -> IncludeSquashedHead -> Bool
/= :: IncludeSquashedHead -> IncludeSquashedHead -> Bool
Eq)

-- | Get a project branch by id.
--
-- On success, update the `remote_project_branch` table.
getProjectBranchById :: IncludeSquashedHead -> ProjectAndBranch RemoteProjectId RemoteProjectBranchId -> Cli GetProjectBranchResponse
getProjectBranchById :: IncludeSquashedHead
-> ProjectAndBranch RemoteProjectId RemoteProjectBranchId
-> Cli GetProjectBranchResponse
getProjectBranchById IncludeSquashedHead
includeSquashed (ProjectAndBranch (RemoteProjectId Text
projectId) (RemoteProjectBranchId Text
branchId)) = do
  let squashed :: Bool
squashed = IncludeSquashedHead
includeSquashed IncludeSquashedHead -> IncludeSquashedHead -> Bool
forall a. Eq a => a -> a -> Bool
== IncludeSquashedHead
IncludeSquashedHead
  GetProjectBranchResponse
response <- ClientM GetProjectBranchResponse
-> Cli (Either ClientError GetProjectBranchResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (Text
-> Maybe Text
-> Maybe Text
-> Bool
-> ClientM GetProjectBranchResponse
getProjectBranch0 Text
projectId (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branchId) Maybe Text
forall a. Maybe a
Nothing Bool
squashed) Cli (Either ClientError GetProjectBranchResponse)
-> (Cli (Either ClientError GetProjectBranchResponse)
    -> Cli GetProjectBranchResponse)
-> Cli GetProjectBranchResponse
forall a b. a -> (a -> b) -> b
& (ClientError -> Cli GetProjectBranchResponse)
-> Cli (Either ClientError GetProjectBranchResponse)
-> Cli GetProjectBranchResponse
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM ClientError -> Cli GetProjectBranchResponse
forall void. ClientError -> Cli void
servantClientError
  GetProjectBranchResponse -> Cli GetProjectBranchResponse
onGetProjectBranchResponse GetProjectBranchResponse
response

-- | Get a project branch by name.
--
-- On success, update the `remote_project_branch` table.
getProjectBranchByName :: IncludeSquashedHead -> ProjectAndBranch RemoteProjectId ProjectBranchName -> Cli GetProjectBranchResponse
getProjectBranchByName :: IncludeSquashedHead
-> ProjectAndBranch RemoteProjectId ProjectBranchName
-> Cli GetProjectBranchResponse
getProjectBranchByName IncludeSquashedHead
includeSquashed (ProjectAndBranch (RemoteProjectId Text
projectId) ProjectBranchName
branchName) = do
  let squashed :: Bool
squashed = IncludeSquashedHead
includeSquashed IncludeSquashedHead -> IncludeSquashedHead -> Bool
forall a. Eq a => a -> a -> Bool
== IncludeSquashedHead
IncludeSquashedHead
  GetProjectBranchResponse
response <-
    ClientM GetProjectBranchResponse
-> Cli (Either ClientError GetProjectBranchResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (Text
-> Maybe Text
-> Maybe Text
-> Bool
-> ClientM GetProjectBranchResponse
getProjectBranch0 Text
projectId Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (forall target source. From source target => source -> target
into @Text ProjectBranchName
branchName)) Bool
squashed)
      Cli (Either ClientError GetProjectBranchResponse)
-> (Cli (Either ClientError GetProjectBranchResponse)
    -> Cli GetProjectBranchResponse)
-> Cli GetProjectBranchResponse
forall a b. a -> (a -> b) -> b
& (ClientError -> Cli GetProjectBranchResponse)
-> Cli (Either ClientError GetProjectBranchResponse)
-> Cli GetProjectBranchResponse
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM ClientError -> Cli GetProjectBranchResponse
forall void. ClientError -> Cli void
servantClientError
  GetProjectBranchResponse -> Cli GetProjectBranchResponse
onGetProjectBranchResponse GetProjectBranchResponse
response

-- | Variant of 'getProjectBranchByName' that returns servant client errors.
getProjectBranchByName' ::
  IncludeSquashedHead ->
  ProjectAndBranch RemoteProjectId ProjectBranchName ->
  Cli (Either Servant.ClientError GetProjectBranchResponse)
getProjectBranchByName' :: IncludeSquashedHead
-> ProjectAndBranch RemoteProjectId ProjectBranchName
-> Cli (Either ClientError GetProjectBranchResponse)
getProjectBranchByName' IncludeSquashedHead
includeSquashed (ProjectAndBranch (RemoteProjectId Text
projectId) ProjectBranchName
branchName) = do
  let squashed :: Bool
squashed = IncludeSquashedHead
includeSquashed IncludeSquashedHead -> IncludeSquashedHead -> Bool
forall a. Eq a => a -> a -> Bool
== IncludeSquashedHead
IncludeSquashedHead
  ClientM GetProjectBranchResponse
-> Cli (Either ClientError GetProjectBranchResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (Text
-> Maybe Text
-> Maybe Text
-> Bool
-> ClientM GetProjectBranchResponse
getProjectBranch0 Text
projectId Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (forall target source. From source target => source -> target
into @Text ProjectBranchName
branchName)) Bool
squashed) Cli (Either ClientError GetProjectBranchResponse)
-> (Either ClientError GetProjectBranchResponse
    -> Cli (Either ClientError GetProjectBranchResponse))
-> Cli (Either ClientError GetProjectBranchResponse)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ClientError
err -> Either ClientError GetProjectBranchResponse
-> Cli (Either ClientError GetProjectBranchResponse)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientError -> Either ClientError GetProjectBranchResponse
forall a b. a -> Either a b
Left ClientError
err)
    Right GetProjectBranchResponse
response -> GetProjectBranchResponse
-> Either ClientError GetProjectBranchResponse
forall a b. b -> Either a b
Right (GetProjectBranchResponse
 -> Either ClientError GetProjectBranchResponse)
-> Cli GetProjectBranchResponse
-> Cli (Either ClientError GetProjectBranchResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetProjectBranchResponse -> Cli GetProjectBranchResponse
onGetProjectBranchResponse GetProjectBranchResponse
response

-- | Create a new project branch.
--
-- On success, update the `remote_project_branch` table.
createProjectBranch :: Share.API.CreateProjectBranchRequest -> Cli (Maybe RemoteProjectBranch)
createProjectBranch :: CreateProjectBranchRequest -> Cli (Maybe RemoteProjectBranch)
createProjectBranch CreateProjectBranchRequest
request =
  ClientM CreateProjectBranchResponse
-> Cli (Either ClientError CreateProjectBranchResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (CreateProjectBranchRequest -> ClientM CreateProjectBranchResponse
createProjectBranch0 CreateProjectBranchRequest
request) Cli (Either ClientError CreateProjectBranchResponse)
-> (Either ClientError CreateProjectBranchResponse
    -> Cli (Maybe RemoteProjectBranch))
-> Cli (Maybe RemoteProjectBranch)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ClientError
err -> ClientError -> Cli (Maybe RemoteProjectBranch)
forall void. ClientError -> Cli void
servantClientError ClientError
err
    Right (Share.API.CreateProjectBranchResponseMissingCausalHash Hash32
hash) -> Hash32 -> Cli (Maybe RemoteProjectBranch)
forall a. Hash32 -> a
bugRemoteMissingCausalHash Hash32
hash
    Right (Share.API.CreateProjectBranchResponseNotFound {}) -> Maybe RemoteProjectBranch -> Cli (Maybe RemoteProjectBranch)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteProjectBranch
forall a. Maybe a
Nothing
    Right (Share.API.CreateProjectBranchResponseUnauthorized Unauthorized
x) -> Unauthorized -> Cli (Maybe RemoteProjectBranch)
forall void. Unauthorized -> Cli void
unauthorized Unauthorized
x
    Right (Share.API.CreateProjectBranchResponseSuccess ProjectBranch
branch) -> RemoteProjectBranch -> Maybe RemoteProjectBranch
forall a. a -> Maybe a
Just (RemoteProjectBranch -> Maybe RemoteProjectBranch)
-> Cli RemoteProjectBranch -> Cli (Maybe RemoteProjectBranch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectBranch -> Cli RemoteProjectBranch
onGotProjectBranch ProjectBranch
branch

data SetProjectBranchHeadResponse
  = SetProjectBranchHeadResponseNotFound
  | -- | (expected, actual)
    SetProjectBranchHeadResponseExpectedCausalHashMismatch !Hash32 !Hash32
  | SetProjectBranchHeadResponsePublishedReleaseIsImmutable
  | SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable
  | SetProjectBranchHeadResponseSuccess
  deriving stock (SetProjectBranchHeadResponse
-> SetProjectBranchHeadResponse -> Bool
(SetProjectBranchHeadResponse
 -> SetProjectBranchHeadResponse -> Bool)
-> (SetProjectBranchHeadResponse
    -> SetProjectBranchHeadResponse -> Bool)
-> Eq SetProjectBranchHeadResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SetProjectBranchHeadResponse
-> SetProjectBranchHeadResponse -> Bool
== :: SetProjectBranchHeadResponse
-> SetProjectBranchHeadResponse -> Bool
$c/= :: SetProjectBranchHeadResponse
-> SetProjectBranchHeadResponse -> Bool
/= :: SetProjectBranchHeadResponse
-> SetProjectBranchHeadResponse -> Bool
Eq, Int -> SetProjectBranchHeadResponse -> ShowS
[SetProjectBranchHeadResponse] -> ShowS
SetProjectBranchHeadResponse -> [Char]
(Int -> SetProjectBranchHeadResponse -> ShowS)
-> (SetProjectBranchHeadResponse -> [Char])
-> ([SetProjectBranchHeadResponse] -> ShowS)
-> Show SetProjectBranchHeadResponse
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetProjectBranchHeadResponse -> ShowS
showsPrec :: Int -> SetProjectBranchHeadResponse -> ShowS
$cshow :: SetProjectBranchHeadResponse -> [Char]
show :: SetProjectBranchHeadResponse -> [Char]
$cshowList :: [SetProjectBranchHeadResponse] -> ShowS
showList :: [SetProjectBranchHeadResponse] -> ShowS
Show, (forall x.
 SetProjectBranchHeadResponse -> Rep SetProjectBranchHeadResponse x)
-> (forall x.
    Rep SetProjectBranchHeadResponse x -> SetProjectBranchHeadResponse)
-> Generic SetProjectBranchHeadResponse
forall x.
Rep SetProjectBranchHeadResponse x -> SetProjectBranchHeadResponse
forall x.
SetProjectBranchHeadResponse -> Rep SetProjectBranchHeadResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
SetProjectBranchHeadResponse -> Rep SetProjectBranchHeadResponse x
from :: forall x.
SetProjectBranchHeadResponse -> Rep SetProjectBranchHeadResponse x
$cto :: forall x.
Rep SetProjectBranchHeadResponse x -> SetProjectBranchHeadResponse
to :: forall x.
Rep SetProjectBranchHeadResponse x -> SetProjectBranchHeadResponse
Generic)

-- | Set a project branch head (can be a fast-forward or force-push).
setProjectBranchHead :: Share.API.SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
setProjectBranchHead :: SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
setProjectBranchHead SetProjectBranchHeadRequest
request =
  ClientM SetProjectBranchHeadResponse
-> Cli (Either ClientError SetProjectBranchHeadResponse)
forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli (SetProjectBranchHeadRequest -> ClientM SetProjectBranchHeadResponse
setProjectBranchHead0 SetProjectBranchHeadRequest
request) Cli (Either ClientError SetProjectBranchHeadResponse)
-> (Either ClientError SetProjectBranchHeadResponse
    -> Cli SetProjectBranchHeadResponse)
-> Cli SetProjectBranchHeadResponse
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ClientError
err -> ClientError -> Cli SetProjectBranchHeadResponse
forall void. ClientError -> Cli void
servantClientError ClientError
err
    Right (Share.API.SetProjectBranchHeadResponseUnauthorized Unauthorized
x) -> Unauthorized -> Cli SetProjectBranchHeadResponse
forall void. Unauthorized -> Cli void
unauthorized Unauthorized
x
    Right (Share.API.SetProjectBranchHeadResponseNotFound NotFound
_) -> SetProjectBranchHeadResponse -> Cli SetProjectBranchHeadResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SetProjectBranchHeadResponse
SetProjectBranchHeadResponseNotFound
    Right (Share.API.SetProjectBranchHeadResponseMissingCausalHash Hash32
hash) -> Hash32 -> Cli SetProjectBranchHeadResponse
forall a. Hash32 -> a
bugRemoteMissingCausalHash Hash32
hash
    Right (Share.API.SetProjectBranchHeadResponseExpectedCausalHashMismatch Hash32
expected Hash32
actual) ->
      SetProjectBranchHeadResponse -> Cli SetProjectBranchHeadResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash32 -> Hash32 -> SetProjectBranchHeadResponse
SetProjectBranchHeadResponseExpectedCausalHashMismatch Hash32
expected Hash32
actual)
    Right (SetProjectBranchHeadResponse
Share.API.SetProjectBranchHeadResponsePublishedReleaseIsImmutable) -> SetProjectBranchHeadResponse -> Cli SetProjectBranchHeadResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SetProjectBranchHeadResponse
SetProjectBranchHeadResponsePublishedReleaseIsImmutable
    Right (SetProjectBranchHeadResponse
Share.API.SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable) -> SetProjectBranchHeadResponse -> Cli SetProjectBranchHeadResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SetProjectBranchHeadResponse
SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable
    Right (SetProjectBranchHeadResponse
Share.API.SetProjectBranchHeadResponseSuccess) -> SetProjectBranchHeadResponse -> Cli SetProjectBranchHeadResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SetProjectBranchHeadResponse
SetProjectBranchHeadResponseSuccess

------------------------------------------------------------------------------------------------------------------------
-- Database manipulation callbacks

onGetProjectResponse :: Share.API.GetProjectResponse -> Cli (Maybe RemoteProject)
onGetProjectResponse :: GetProjectResponse -> Cli (Maybe RemoteProject)
onGetProjectResponse = \case
  -- FIXME should we mark remote project as deleted?
  Share.API.GetProjectResponseNotFound {} -> Maybe RemoteProject -> Cli (Maybe RemoteProject)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteProject
forall a. Maybe a
Nothing
  Share.API.GetProjectResponseUnauthorized Unauthorized
x -> Unauthorized -> Cli (Maybe RemoteProject)
forall void. Unauthorized -> Cli void
unauthorized Unauthorized
x
  Share.API.GetProjectResponseSuccess Project
project -> RemoteProject -> Maybe RemoteProject
forall a. a -> Maybe a
Just (RemoteProject -> Maybe RemoteProject)
-> Cli RemoteProject -> Cli (Maybe RemoteProject)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Project -> Cli RemoteProject
onGotProject Project
project

onGetProjectBranchResponse :: Share.API.GetProjectBranchResponse -> Cli GetProjectBranchResponse
onGetProjectBranchResponse :: GetProjectBranchResponse -> Cli GetProjectBranchResponse
onGetProjectBranchResponse = \case
  -- FIXME should we mark remote project/branch as deleted in these two cases?
  Share.API.GetProjectBranchResponseBranchNotFound {} -> GetProjectBranchResponse -> Cli GetProjectBranchResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GetProjectBranchResponse
GetProjectBranchResponseBranchNotFound
  Share.API.GetProjectBranchResponseProjectNotFound {} -> GetProjectBranchResponse -> Cli GetProjectBranchResponse
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GetProjectBranchResponse
GetProjectBranchResponseProjectNotFound
  Share.API.GetProjectBranchResponseUnauthorized Unauthorized
x -> Unauthorized -> Cli GetProjectBranchResponse
forall void. Unauthorized -> Cli void
unauthorized Unauthorized
x
  Share.API.GetProjectBranchResponseSuccess ProjectBranch
branch -> RemoteProjectBranch -> GetProjectBranchResponse
GetProjectBranchResponseSuccess (RemoteProjectBranch -> GetProjectBranchResponse)
-> Cli RemoteProjectBranch -> Cli GetProjectBranchResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectBranch -> Cli RemoteProjectBranch
onGotProjectBranch ProjectBranch
branch

onGotProject :: Share.API.Project -> Cli RemoteProject
onGotProject :: Project -> Cli RemoteProject
onGotProject Project
project = do
  let projectId :: RemoteProjectId
projectId = Text -> RemoteProjectId
RemoteProjectId (Project
project Project -> Getting Text Project Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Project Text
#projectId)
  ProjectName
projectName <- Text -> Cli ProjectName
validateProjectName (Project
project Project -> Getting Text Project Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Project Text
#projectName)
  let latestRelease :: Maybe Semver
latestRelease = (Project
project Project -> Getting (Maybe Text) Project (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Project (Maybe Text)
#latestRelease) Maybe Text -> (Text -> Maybe Semver) -> Maybe Semver
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either (TryFromException Text Semver) Semver -> Maybe Semver
forall a b. Either a b -> Maybe b
eitherToMaybe (Either (TryFromException Text Semver) Semver -> Maybe Semver)
-> (Text -> Either (TryFromException Text Semver) Semver)
-> Text
-> Maybe Semver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target.
TryFrom source target =>
source -> Either (TryFromException source target) target
tryFrom @Text
  Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction (RemoteProjectId -> URI -> ProjectName -> Transaction ()
Queries.ensureRemoteProject RemoteProjectId
projectId URI
hardCodedUri ProjectName
projectName)
  pure RemoteProject {RemoteProjectId
projectId :: RemoteProjectId
$sel:projectId:RemoteProject :: RemoteProjectId
projectId, ProjectName
projectName :: ProjectName
$sel:projectName:RemoteProject :: ProjectName
projectName, Maybe Semver
latestRelease :: Maybe Semver
$sel:latestRelease:RemoteProject :: Maybe Semver
latestRelease}

onGotProjectBranch :: Share.API.ProjectBranch -> Cli RemoteProjectBranch
onGotProjectBranch :: ProjectBranch -> Cli RemoteProjectBranch
onGotProjectBranch ProjectBranch
branch = do
  let projectId :: RemoteProjectId
projectId = Text -> RemoteProjectId
RemoteProjectId (ProjectBranch
branch ProjectBranch -> Getting Text ProjectBranch Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ProjectBranch Text
#projectId)
  let branchId :: RemoteProjectBranchId
branchId = Text -> RemoteProjectBranchId
RemoteProjectBranchId (ProjectBranch
branch ProjectBranch -> Getting Text ProjectBranch Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ProjectBranch Text
#branchId)
  ProjectName
projectName <- Text -> Cli ProjectName
validateProjectName (ProjectBranch
branch ProjectBranch -> Getting Text ProjectBranch Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ProjectBranch Text
#projectName)
  ProjectBranchName
branchName <- Text -> Cli ProjectBranchName
validateBranchName (ProjectBranch
branch ProjectBranch -> Getting Text ProjectBranch Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ProjectBranch Text
#branchName)
  Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction do
    RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> ProjectBranchName
-> Transaction ()
Queries.ensureRemoteProjectBranch
      RemoteProjectId
projectId
      URI
hardCodedUri
      RemoteProjectBranchId
branchId
      ProjectBranchName
branchName
  pure
    RemoteProjectBranch
      { RemoteProjectId
projectId :: RemoteProjectId
$sel:projectId:RemoteProjectBranch :: RemoteProjectId
projectId,
        ProjectName
projectName :: ProjectName
$sel:projectName:RemoteProjectBranch :: ProjectName
projectName,
        RemoteProjectBranchId
branchId :: RemoteProjectBranchId
$sel:branchId:RemoteProjectBranch :: RemoteProjectBranchId
branchId,
        ProjectBranchName
branchName :: ProjectBranchName
$sel:branchName:RemoteProjectBranch :: ProjectBranchName
branchName,
        $sel:branchHead:RemoteProjectBranch :: HashJWT
branchHead = ProjectBranch
branch ProjectBranch -> Getting HashJWT ProjectBranch HashJWT -> HashJWT
forall s a. s -> Getting a s a -> a
^. Getting HashJWT ProjectBranch HashJWT
#branchHead,
        $sel:squashedBranchHead:RemoteProjectBranch :: Maybe HashJWT
squashedBranchHead = ProjectBranch
branch ProjectBranch
-> Getting (Maybe HashJWT) ProjectBranch (Maybe HashJWT)
-> Maybe HashJWT
forall s a. s -> Getting a s a -> a
^. Getting (Maybe HashJWT) ProjectBranch (Maybe HashJWT)
#squashedBranchHead
      }

validateProjectName :: Text -> Cli ProjectName
validateProjectName :: Text -> Cli ProjectName
validateProjectName Text
projectName =
  forall target source.
TryFrom source target =>
source -> Either (TryFromException source target) target
tryInto @ProjectName Text
projectName Either (TryFromException Text ProjectName) ProjectName
-> (Either (TryFromException Text ProjectName) ProjectName
    -> Cli ProjectName)
-> Cli ProjectName
forall a b. a -> (a -> b) -> b
& (TryFromException Text ProjectName -> Cli ProjectName)
-> Either (TryFromException Text ProjectName) ProjectName
-> Cli ProjectName
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
onLeft \TryFromException Text ProjectName
_ ->
    Output -> Cli ProjectName
forall a. Output -> Cli a
Cli.returnEarly (Text -> Output
Output.InvalidProjectName Text
projectName)

validateBranchName :: Text -> Cli ProjectBranchName
validateBranchName :: Text -> Cli ProjectBranchName
validateBranchName Text
branchName =
  forall target source.
TryFrom source target =>
source -> Either (TryFromException source target) target
tryInto @ProjectBranchName Text
branchName Either (TryFromException Text ProjectBranchName) ProjectBranchName
-> (Either
      (TryFromException Text ProjectBranchName) ProjectBranchName
    -> Cli ProjectBranchName)
-> Cli ProjectBranchName
forall a b. a -> (a -> b) -> b
& (TryFromException Text ProjectBranchName -> Cli ProjectBranchName)
-> Either
     (TryFromException Text ProjectBranchName) ProjectBranchName
-> Cli ProjectBranchName
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
onLeft \TryFromException Text ProjectBranchName
_ ->
    Output -> Cli ProjectBranchName
forall a. Output -> Cli a
Cli.returnEarly (Text -> Output
Output.InvalidProjectBranchName Text
branchName)

servantClientError :: Servant.ClientError -> Cli void
servantClientError :: forall void. ClientError -> Cli void
servantClientError =
  Output -> Cli void
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli void)
-> (ClientError -> Output) -> ClientError -> Cli void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> Output
Output.ServantClientError

unauthorized :: Share.API.Unauthorized -> Cli void
unauthorized :: forall void. Unauthorized -> Cli void
unauthorized (Share.API.Unauthorized Text
message) =
  Output -> Cli void
forall a. Output -> Cli a
Cli.returnEarly (Text -> Output
Output.Unauthorized Text
message)

bugRemoteMissingCausalHash :: Hash32 -> a
bugRemoteMissingCausalHash :: forall a. Hash32 -> a
bugRemoteMissingCausalHash Hash32
hash =
  [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> ShowS
reportBug [Char]
"E796475" ([Char]
"Create remote branch: causal hash missing: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Hash32 -> [Char]
forall a. Show a => a -> [Char]
show Hash32
hash))

------------------------------------------------------------------------------------------------------------------------
-- Low-level servant client generation and wrapping

-- For now, since there's no syntax for specifying an alternative share server in any of the UCM commands, we
-- just hard-code the default codeserver here.
hardCodedBaseUrl :: BaseUrl
hardCodedBaseUrl :: BaseUrl
hardCodedBaseUrl =
  CodeserverURI -> BaseUrl
codeserverBaseURL CodeserverURI
defaultCodeserver

-- Like hardCodedBaseUri using an isomorphic-ish type
hardCodedUri :: URI
hardCodedUri :: URI
hardCodedUri =
  case [Char] -> Maybe URI
URI.parseURI (BaseUrl -> [Char]
showBaseUrl BaseUrl
hardCodedBaseUrl) of
    Maybe URI
Nothing -> [Char] -> URI
forall a. HasCallStack => [Char] -> a
error ([Char]
"BaseUrl is an invalid URI: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ BaseUrl -> [Char]
showBaseUrl BaseUrl
hardCodedBaseUrl)
    Just URI
uri -> URI
uri

servantClientToCli :: ClientM a -> Cli (Either Servant.ClientError a)
servantClientToCli :: forall a. ClientM a -> Cli (Either ClientError a)
servantClientToCli ClientM a
action = do
  Cli.Env {$sel:authHTTPClient:Env :: Env -> AuthenticatedHttpClient
authHTTPClient = Auth.AuthenticatedHttpClient Manager
httpManager} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask

  let clientEnv :: ClientEnv
      clientEnv :: ClientEnv
clientEnv =
        (Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
httpManager BaseUrl
hardCodedBaseUrl)
          { Servant.makeClientRequest = \BaseUrl
url Request
request ->
              (BaseUrl -> Request -> IO Request
Servant.defaultMakeClientRequest BaseUrl
url Request
request)
                IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Request
req ->
                  Request
req
                    { Http.Client.responseTimeout = Http.Client.responseTimeoutMicro (60 * 1000 * 1000 {- 60s -})
                    }
          }

  IO (Either ClientError a) -> Cli (Either ClientError a)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
action ClientEnv
clientEnv)

getProject0 :: Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectResponse
createProject0 :: Share.API.CreateProjectRequest -> ClientM Share.API.CreateProjectResponse
getProjectBranch0 :: Text -> Maybe Text -> Maybe Text -> Bool -> ClientM Share.API.GetProjectBranchResponse
createProjectBranch0 :: Share.API.CreateProjectBranchRequest -> ClientM Share.API.CreateProjectBranchResponse
setProjectBranchHead0 :: Share.API.SetProjectBranchHeadRequest -> ClientM Share.API.SetProjectBranchHeadResponse
( Maybe Text -> Maybe Text -> ClientM GetProjectResponse
getProject0
    :<|> CreateProjectRequest -> ClientM CreateProjectResponse
createProject0
    :<|> Text
-> Maybe Text
-> Maybe Text
-> Bool
-> ClientM GetProjectBranchResponse
getProjectBranch0
    :<|> CreateProjectBranchRequest -> ClientM CreateProjectBranchResponse
createProjectBranch0
    :<|> SetProjectBranchHeadRequest -> ClientM SetProjectBranchHeadResponse
setProjectBranchHead0
  ) =
    Proxy ("ucm" :> ("v1" :> ("projects" :> ProjectsAPI)))
-> Client ClientM ("ucm" :> ("v1" :> ("projects" :> ProjectsAPI)))
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (Proxy ("ucm" :> ("v1" :> ("projects" :> ProjectsAPI)))
forall {k} (t :: k). Proxy t
Proxy :: Proxy ("ucm" :> "v1" :> "projects" :> Share.API.ProjectsAPI))