mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 11:07:48 +03:00
download latest version of base on project.create
This commit is contained in:
parent
f28bb87d03
commit
bb818d5fec
@ -75,6 +75,7 @@ module U.Codebase.Sqlite.Queries
|
|||||||
-- ** causal table
|
-- ** causal table
|
||||||
saveCausal,
|
saveCausal,
|
||||||
isCausalHash,
|
isCausalHash,
|
||||||
|
causalExistsByHash32,
|
||||||
expectCausal,
|
expectCausal,
|
||||||
loadCausalHashIdByCausalHash,
|
loadCausalHashIdByCausalHash,
|
||||||
expectCausalHashIdByCausalHash,
|
expectCausalHashIdByCausalHash,
|
||||||
@ -1215,6 +1216,19 @@ isCausalHash hash =
|
|||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
-- | Return whether or not a causal exists with the given hash32.
|
||||||
|
causalExistsByHash32 :: Hash32 -> Transaction Bool
|
||||||
|
causalExistsByHash32 hash =
|
||||||
|
queryOneCol
|
||||||
|
[sql|
|
||||||
|
SELECT EXISTS (
|
||||||
|
SELECT 1
|
||||||
|
FROM causal
|
||||||
|
JOIN hash ON causal.self_hash_id = hash.id
|
||||||
|
WHERE hash.base32 = :hash
|
||||||
|
)
|
||||||
|
|]
|
||||||
|
|
||||||
loadBranchObjectIdByCausalHashId :: CausalHashId -> Transaction (Maybe BranchObjectId)
|
loadBranchObjectIdByCausalHashId :: CausalHashId -> Transaction (Maybe BranchObjectId)
|
||||||
loadBranchObjectIdByCausalHashId id = queryMaybeCol (loadBranchObjectIdByCausalHashIdSql id)
|
loadBranchObjectIdByCausalHashId id = queryMaybeCol (loadBranchObjectIdByCausalHashIdSql id)
|
||||||
|
|
||||||
|
@ -189,6 +189,7 @@ default-extensions:
|
|||||||
- InstanceSigs
|
- InstanceSigs
|
||||||
- LambdaCase
|
- LambdaCase
|
||||||
- MultiParamTypeClasses
|
- MultiParamTypeClasses
|
||||||
|
- MultiWayIf
|
||||||
- NamedFieldPuns
|
- NamedFieldPuns
|
||||||
- NumericUnderscores
|
- NumericUnderscores
|
||||||
- OverloadedLabels
|
- OverloadedLabels
|
||||||
|
35
unison-cli/src/Unison/Cli/ServantClientUtils.hs
Normal file
35
unison-cli/src/Unison/Cli/ServantClientUtils.hs
Normal file
@ -0,0 +1,35 @@
|
|||||||
|
-- | servant-client utilities
|
||||||
|
module Unison.Cli.ServantClientUtils
|
||||||
|
( ConnectionError (..),
|
||||||
|
classifyConnectionError,
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Control.Exception (fromException)
|
||||||
|
import Network.HTTP.Client qualified as HttpClient
|
||||||
|
import System.IO.Error (isDoesNotExistError)
|
||||||
|
import Unison.Prelude
|
||||||
|
|
||||||
|
data ConnectionError
|
||||||
|
= ConnectionError'Offline
|
||||||
|
| ConnectionError'SomethingElse HttpClient.HttpExceptionContent
|
||||||
|
| ConnectionError'SomethingEntirelyUnexpected SomeException
|
||||||
|
|
||||||
|
-- | Given a 'SomeException' from a @servant-client@ 'ClientError', attempt to classify what happened.
|
||||||
|
classifyConnectionError :: SomeException -> ConnectionError
|
||||||
|
classifyConnectionError exception0 =
|
||||||
|
case fromException exception0 of
|
||||||
|
Just (HttpClient.HttpExceptionRequest _request content) ->
|
||||||
|
fromMaybe (ConnectionError'SomethingElse content) do
|
||||||
|
case content of
|
||||||
|
HttpClient.ConnectionFailure exception1 -> do
|
||||||
|
ioException <- fromException @IOException exception1
|
||||||
|
if
|
||||||
|
| -- This may not be 100% accurate... but if the initial `getAddrInfo` request fails it will indeed throw
|
||||||
|
-- a "does not exist" error. It seems in order to *know* that `getAddrInfo` was the cause of this
|
||||||
|
-- exception, we'd have to parse the `show` output, which is preposterous.
|
||||||
|
isDoesNotExistError ioException ->
|
||||||
|
Just ConnectionError'Offline
|
||||||
|
| otherwise -> Nothing
|
||||||
|
_ -> Nothing
|
||||||
|
_ -> ConnectionError'SomethingEntirelyUnexpected exception0
|
@ -14,10 +14,12 @@ module Unison.Cli.Share.Projects
|
|||||||
-- * API functions
|
-- * API functions
|
||||||
getProjectById,
|
getProjectById,
|
||||||
getProjectByName,
|
getProjectByName,
|
||||||
|
getProjectByName',
|
||||||
createProject,
|
createProject,
|
||||||
GetProjectBranchResponse (..),
|
GetProjectBranchResponse (..),
|
||||||
getProjectBranchById,
|
getProjectBranchById,
|
||||||
getProjectBranchByName,
|
getProjectBranchByName,
|
||||||
|
getProjectBranchByName',
|
||||||
createProjectBranch,
|
createProjectBranch,
|
||||||
SetProjectBranchHeadResponse (..),
|
SetProjectBranchHeadResponse (..),
|
||||||
setProjectBranchHead,
|
setProjectBranchHead,
|
||||||
@ -35,6 +37,7 @@ import Network.URI (URI)
|
|||||||
import Network.URI qualified as URI
|
import Network.URI qualified as URI
|
||||||
import Servant.API ((:<|>) (..), (:>))
|
import Servant.API ((:<|>) (..), (:>))
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
|
import Servant.Client qualified as Servant
|
||||||
import U.Codebase.Sqlite.DbId (RemoteProjectBranchId (..), RemoteProjectId (..))
|
import U.Codebase.Sqlite.DbId (RemoteProjectBranchId (..), RemoteProjectId (..))
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Auth.HTTPClient qualified as Auth
|
import Unison.Auth.HTTPClient qualified as Auth
|
||||||
@ -54,16 +57,22 @@ import Unison.Share.Types (codeserverBaseURL)
|
|||||||
-- On success, update the `remote_project` table.
|
-- On success, update the `remote_project` table.
|
||||||
getProjectById :: RemoteProjectId -> Cli (Maybe RemoteProject)
|
getProjectById :: RemoteProjectId -> Cli (Maybe RemoteProject)
|
||||||
getProjectById (RemoteProjectId projectId) = do
|
getProjectById (RemoteProjectId projectId) = do
|
||||||
response <- servantClientToCli (getProject0 (Just projectId) Nothing)
|
response <- servantClientToCli (getProject0 (Just projectId) Nothing) & onLeftM servantClientError
|
||||||
onGetProjectResponse response
|
onGetProjectResponse response
|
||||||
|
|
||||||
-- | Get a project by name.
|
-- | Get a project by name.
|
||||||
--
|
--
|
||||||
-- On success, update the `remote_project` table.
|
-- On success, update the `remote_project` table.
|
||||||
getProjectByName :: ProjectName -> Cli (Maybe RemoteProject)
|
getProjectByName :: ProjectName -> Cli (Maybe RemoteProject)
|
||||||
getProjectByName projectName = do
|
getProjectByName projectName =
|
||||||
response <- servantClientToCli (getProject0 Nothing (Just (into @Text projectName)))
|
getProjectByName' projectName & onLeftM servantClientError
|
||||||
onGetProjectResponse response
|
|
||||||
|
-- | Variant of 'getProjectByName' that returns servant client errors.
|
||||||
|
getProjectByName' :: ProjectName -> Cli (Either Servant.ClientError (Maybe RemoteProject))
|
||||||
|
getProjectByName' projectName = do
|
||||||
|
servantClientToCli (getProject0 Nothing (Just (into @Text projectName))) >>= \case
|
||||||
|
Left err -> pure (Left err)
|
||||||
|
Right response -> Right <$> onGetProjectResponse response
|
||||||
|
|
||||||
-- | Create a new project. Kinda weird: returns `Nothing` if the user handle part of the project doesn't exist.
|
-- | Create a new project. Kinda weird: returns `Nothing` if the user handle part of the project doesn't exist.
|
||||||
--
|
--
|
||||||
@ -72,9 +81,10 @@ createProject :: ProjectName -> Cli (Maybe RemoteProject)
|
|||||||
createProject projectName = do
|
createProject projectName = do
|
||||||
let request = Share.API.CreateProjectRequest {projectName = into @Text projectName}
|
let request = Share.API.CreateProjectRequest {projectName = into @Text projectName}
|
||||||
servantClientToCli (createProject0 request) >>= \case
|
servantClientToCli (createProject0 request) >>= \case
|
||||||
Share.API.CreateProjectResponseNotFound {} -> pure Nothing
|
Left err -> servantClientError err
|
||||||
Share.API.CreateProjectResponseUnauthorized x -> unauthorized x
|
Right (Share.API.CreateProjectResponseNotFound {}) -> pure Nothing
|
||||||
Share.API.CreateProjectResponseSuccess project -> Just <$> onGotProject project
|
Right (Share.API.CreateProjectResponseUnauthorized x) -> unauthorized x
|
||||||
|
Right (Share.API.CreateProjectResponseSuccess project) -> Just <$> onGotProject project
|
||||||
|
|
||||||
data GetProjectBranchResponse
|
data GetProjectBranchResponse
|
||||||
= GetProjectBranchResponseBranchNotFound
|
= GetProjectBranchResponseBranchNotFound
|
||||||
@ -86,7 +96,7 @@ data GetProjectBranchResponse
|
|||||||
-- On success, update the `remote_project_branch` table.
|
-- On success, update the `remote_project_branch` table.
|
||||||
getProjectBranchById :: ProjectAndBranch RemoteProjectId RemoteProjectBranchId -> Cli GetProjectBranchResponse
|
getProjectBranchById :: ProjectAndBranch RemoteProjectId RemoteProjectBranchId -> Cli GetProjectBranchResponse
|
||||||
getProjectBranchById (ProjectAndBranch (RemoteProjectId projectId) (RemoteProjectBranchId branchId)) = do
|
getProjectBranchById (ProjectAndBranch (RemoteProjectId projectId) (RemoteProjectBranchId branchId)) = do
|
||||||
response <- servantClientToCli (getProjectBranch0 projectId (Just branchId) Nothing)
|
response <- servantClientToCli (getProjectBranch0 projectId (Just branchId) Nothing) & onLeftM servantClientError
|
||||||
onGetProjectBranchResponse response
|
onGetProjectBranchResponse response
|
||||||
|
|
||||||
-- | Get a project branch by name.
|
-- | Get a project branch by name.
|
||||||
@ -94,19 +104,31 @@ getProjectBranchById (ProjectAndBranch (RemoteProjectId projectId) (RemoteProjec
|
|||||||
-- On success, update the `remote_project_branch` table.
|
-- On success, update the `remote_project_branch` table.
|
||||||
getProjectBranchByName :: ProjectAndBranch RemoteProjectId ProjectBranchName -> Cli GetProjectBranchResponse
|
getProjectBranchByName :: ProjectAndBranch RemoteProjectId ProjectBranchName -> Cli GetProjectBranchResponse
|
||||||
getProjectBranchByName (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
|
getProjectBranchByName (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
|
||||||
response <- servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName)))
|
response <-
|
||||||
|
servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName)))
|
||||||
|
& onLeftM servantClientError
|
||||||
onGetProjectBranchResponse response
|
onGetProjectBranchResponse response
|
||||||
|
|
||||||
|
-- | Variant of 'getProjectBranchByName' that returns servant client errors.
|
||||||
|
getProjectBranchByName' ::
|
||||||
|
ProjectAndBranch RemoteProjectId ProjectBranchName ->
|
||||||
|
Cli (Either Servant.ClientError GetProjectBranchResponse)
|
||||||
|
getProjectBranchByName' (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
|
||||||
|
servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName))) >>= \case
|
||||||
|
Left err -> pure (Left err)
|
||||||
|
Right response -> Right <$> onGetProjectBranchResponse response
|
||||||
|
|
||||||
-- | Create a new project branch.
|
-- | Create a new project branch.
|
||||||
--
|
--
|
||||||
-- On success, update the `remote_project_branch` table.
|
-- On success, update the `remote_project_branch` table.
|
||||||
createProjectBranch :: Share.API.CreateProjectBranchRequest -> Cli (Maybe RemoteProjectBranch)
|
createProjectBranch :: Share.API.CreateProjectBranchRequest -> Cli (Maybe RemoteProjectBranch)
|
||||||
createProjectBranch request =
|
createProjectBranch request =
|
||||||
servantClientToCli (createProjectBranch0 request) >>= \case
|
servantClientToCli (createProjectBranch0 request) >>= \case
|
||||||
Share.API.CreateProjectBranchResponseMissingCausalHash hash -> bugRemoteMissingCausalHash hash
|
Left err -> servantClientError err
|
||||||
Share.API.CreateProjectBranchResponseNotFound {} -> pure Nothing
|
Right (Share.API.CreateProjectBranchResponseMissingCausalHash hash) -> bugRemoteMissingCausalHash hash
|
||||||
Share.API.CreateProjectBranchResponseUnauthorized x -> unauthorized x
|
Right (Share.API.CreateProjectBranchResponseNotFound {}) -> pure Nothing
|
||||||
Share.API.CreateProjectBranchResponseSuccess branch -> Just <$> onGotProjectBranch branch
|
Right (Share.API.CreateProjectBranchResponseUnauthorized x) -> unauthorized x
|
||||||
|
Right (Share.API.CreateProjectBranchResponseSuccess branch) -> Just <$> onGotProjectBranch branch
|
||||||
|
|
||||||
data SetProjectBranchHeadResponse
|
data SetProjectBranchHeadResponse
|
||||||
= SetProjectBranchHeadResponseNotFound
|
= SetProjectBranchHeadResponseNotFound
|
||||||
@ -121,14 +143,15 @@ data SetProjectBranchHeadResponse
|
|||||||
setProjectBranchHead :: Share.API.SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
|
setProjectBranchHead :: Share.API.SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
|
||||||
setProjectBranchHead request =
|
setProjectBranchHead request =
|
||||||
servantClientToCli (setProjectBranchHead0 request) >>= \case
|
servantClientToCli (setProjectBranchHead0 request) >>= \case
|
||||||
Share.API.SetProjectBranchHeadResponseUnauthorized x -> unauthorized x
|
Left err -> servantClientError err
|
||||||
Share.API.SetProjectBranchHeadResponseNotFound _ -> pure SetProjectBranchHeadResponseNotFound
|
Right (Share.API.SetProjectBranchHeadResponseUnauthorized x) -> unauthorized x
|
||||||
Share.API.SetProjectBranchHeadResponseMissingCausalHash hash -> bugRemoteMissingCausalHash hash
|
Right (Share.API.SetProjectBranchHeadResponseNotFound _) -> pure SetProjectBranchHeadResponseNotFound
|
||||||
Share.API.SetProjectBranchHeadResponseExpectedCausalHashMismatch expected actual ->
|
Right (Share.API.SetProjectBranchHeadResponseMissingCausalHash hash) -> bugRemoteMissingCausalHash hash
|
||||||
|
Right (Share.API.SetProjectBranchHeadResponseExpectedCausalHashMismatch expected actual) ->
|
||||||
pure (SetProjectBranchHeadResponseExpectedCausalHashMismatch expected actual)
|
pure (SetProjectBranchHeadResponseExpectedCausalHashMismatch expected actual)
|
||||||
Share.API.SetProjectBranchHeadResponsePublishedReleaseIsImmutable -> pure SetProjectBranchHeadResponsePublishedReleaseIsImmutable
|
Right (Share.API.SetProjectBranchHeadResponsePublishedReleaseIsImmutable) -> pure SetProjectBranchHeadResponsePublishedReleaseIsImmutable
|
||||||
Share.API.SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable -> pure SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable
|
Right (Share.API.SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable) -> pure SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable
|
||||||
Share.API.SetProjectBranchHeadResponseSuccess -> pure SetProjectBranchHeadResponseSuccess
|
Right (Share.API.SetProjectBranchHeadResponseSuccess) -> pure SetProjectBranchHeadResponseSuccess
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Database manipulation callbacks
|
-- Database manipulation callbacks
|
||||||
@ -152,8 +175,9 @@ onGotProject :: Share.API.Project -> Cli RemoteProject
|
|||||||
onGotProject project = do
|
onGotProject project = do
|
||||||
let projectId = RemoteProjectId (project ^. #projectId)
|
let projectId = RemoteProjectId (project ^. #projectId)
|
||||||
projectName <- validateProjectName (project ^. #projectName)
|
projectName <- validateProjectName (project ^. #projectName)
|
||||||
|
let latestRelease = (project ^. #latestRelease) >>= eitherToMaybe . tryFrom @Text
|
||||||
Cli.runTransaction (Queries.ensureRemoteProject projectId hardCodedUri projectName)
|
Cli.runTransaction (Queries.ensureRemoteProject projectId hardCodedUri projectName)
|
||||||
pure RemoteProject {projectId, projectName}
|
pure RemoteProject {projectId, projectName, latestRelease}
|
||||||
|
|
||||||
onGotProjectBranch :: Share.API.ProjectBranch -> Cli RemoteProjectBranch
|
onGotProjectBranch :: Share.API.ProjectBranch -> Cli RemoteProjectBranch
|
||||||
onGotProjectBranch branch = do
|
onGotProjectBranch branch = do
|
||||||
@ -186,6 +210,10 @@ validateBranchName branchName =
|
|||||||
tryInto @ProjectBranchName branchName & onLeft \_ ->
|
tryInto @ProjectBranchName branchName & onLeft \_ ->
|
||||||
Cli.returnEarly (Output.InvalidProjectBranchName branchName)
|
Cli.returnEarly (Output.InvalidProjectBranchName branchName)
|
||||||
|
|
||||||
|
servantClientError :: Servant.ClientError -> Cli void
|
||||||
|
servantClientError =
|
||||||
|
Cli.returnEarly . Output.ServantClientError
|
||||||
|
|
||||||
unauthorized :: Share.API.Unauthorized -> Cli void
|
unauthorized :: Share.API.Unauthorized -> Cli void
|
||||||
unauthorized (Share.API.Unauthorized message) =
|
unauthorized (Share.API.Unauthorized message) =
|
||||||
Cli.returnEarly (Output.Unauthorized message)
|
Cli.returnEarly (Output.Unauthorized message)
|
||||||
@ -210,7 +238,7 @@ hardCodedUri =
|
|||||||
Nothing -> error ("BaseUrl is an invalid URI: " ++ showBaseUrl hardCodedBaseUrl)
|
Nothing -> error ("BaseUrl is an invalid URI: " ++ showBaseUrl hardCodedBaseUrl)
|
||||||
Just uri -> uri
|
Just uri -> uri
|
||||||
|
|
||||||
servantClientToCli :: ClientM a -> Cli a
|
servantClientToCli :: ClientM a -> Cli (Either Servant.ClientError a)
|
||||||
servantClientToCli action = do
|
servantClientToCli action = do
|
||||||
Cli.Env {authHTTPClient = Auth.AuthenticatedHttpClient httpManager} <- ask
|
Cli.Env {authHTTPClient = Auth.AuthenticatedHttpClient httpManager} <- ask
|
||||||
|
|
||||||
@ -218,8 +246,7 @@ servantClientToCli action = do
|
|||||||
clientEnv =
|
clientEnv =
|
||||||
mkClientEnv httpManager hardCodedBaseUrl
|
mkClientEnv httpManager hardCodedBaseUrl
|
||||||
|
|
||||||
liftIO (runClientM action clientEnv) & onLeftM \err ->
|
liftIO (runClientM action clientEnv)
|
||||||
Cli.returnEarly (Output.ServantClientError err)
|
|
||||||
|
|
||||||
getProject0 :: Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectResponse
|
getProject0 :: Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectResponse
|
||||||
createProject0 :: Share.API.CreateProjectRequest -> ClientM Share.API.CreateProjectResponse
|
createProject0 :: Share.API.CreateProjectRequest -> ClientM Share.API.CreateProjectResponse
|
||||||
|
@ -9,13 +9,14 @@ where
|
|||||||
|
|
||||||
import U.Codebase.Sqlite.DbId (RemoteProjectBranchId (..), RemoteProjectId (..))
|
import U.Codebase.Sqlite.DbId (RemoteProjectBranchId (..), RemoteProjectId (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectBranchName, ProjectName, Semver)
|
||||||
import Unison.Share.API.Hash qualified as Share.API
|
import Unison.Share.API.Hash qualified as Share.API
|
||||||
|
|
||||||
-- | A remote project.
|
-- | A remote project.
|
||||||
data RemoteProject = RemoteProject
|
data RemoteProject = RemoteProject
|
||||||
{ projectId :: RemoteProjectId,
|
{ projectId :: RemoteProjectId,
|
||||||
projectName :: ProjectName
|
projectName :: ProjectName,
|
||||||
|
latestRelease :: Maybe Semver
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Generic, Show)
|
deriving stock (Eq, Generic, Show)
|
||||||
|
|
||||||
|
@ -4,6 +4,9 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Lens (over, (^.))
|
||||||
|
import Control.Monad.Reader (ask)
|
||||||
|
import Data.Map.Strict qualified as Map
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.UUID.V4 qualified as UUID
|
import Data.UUID.V4 qualified as UUID
|
||||||
import System.Random.Shuffle qualified as RandomShuffle
|
import System.Random.Shuffle qualified as RandomShuffle
|
||||||
@ -14,12 +17,19 @@ import Unison.Cli.Monad (Cli)
|
|||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli (stepAt)
|
import Unison.Cli.MonadUtils qualified as Cli (stepAt)
|
||||||
import Unison.Cli.ProjectUtils (projectBranchPath)
|
import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||||
|
import Unison.Cli.Share.Projects qualified as Share
|
||||||
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
|
import Unison.Codebase.Editor.HandleInput.Pull qualified as Pull
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Name qualified as Name
|
||||||
|
import Unison.NameSegment (NameSegment (NameSegment))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||||
|
import Unison.Share.API.Hash qualified as Share.API
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
|
import Unison.Sync.Common qualified as Sync.Common
|
||||||
import Witch (unsafeFrom)
|
import Witch (unsafeFrom)
|
||||||
|
|
||||||
-- | Create a new project.
|
-- | Create a new project.
|
||||||
@ -78,10 +88,64 @@ projectCreate maybeProjectName = do
|
|||||||
True -> pure (Left (Output.ProjectNameAlreadyExists projectName))
|
True -> pure (Left (Output.ProjectNameAlreadyExists projectName))
|
||||||
|
|
||||||
let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
|
let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
|
||||||
Cli.stepAt "project.create" (Path.unabsolute path, const Branch.empty0)
|
|
||||||
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
|
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
|
||||||
Cli.cd path
|
Cli.cd path
|
||||||
|
|
||||||
|
Cli.respond Output.FetchingLatestReleaseOfBase
|
||||||
|
|
||||||
|
-- Make an effort to pull the latest release of base, which can go wrong in a number of ways, the most likely of
|
||||||
|
-- which is that the user is offline.
|
||||||
|
maybeBaseLatestReleaseBranchObject <-
|
||||||
|
Cli.label \done -> do
|
||||||
|
baseProject <-
|
||||||
|
Share.getProjectByName' (unsafeFrom @Text "@unison/base") >>= \case
|
||||||
|
Right (Just baseProject) -> pure baseProject
|
||||||
|
_ -> done Nothing
|
||||||
|
ver <- baseProject ^. #latestRelease & onNothing (done Nothing)
|
||||||
|
let baseProjectId = baseProject ^. #projectId
|
||||||
|
let baseLatestReleaseBranchName = unsafeFrom @Text ("releases/" <> into @Text ver)
|
||||||
|
response <-
|
||||||
|
Share.getProjectBranchByName' (ProjectAndBranch baseProjectId baseLatestReleaseBranchName)
|
||||||
|
& onLeftM \_err -> done Nothing
|
||||||
|
baseLatestReleaseBranch <-
|
||||||
|
case response of
|
||||||
|
Share.GetProjectBranchResponseBranchNotFound -> done Nothing
|
||||||
|
Share.GetProjectBranchResponseProjectNotFound -> done Nothing
|
||||||
|
Share.GetProjectBranchResponseSuccess branch -> pure branch
|
||||||
|
Pull.downloadShareProjectBranch baseLatestReleaseBranch
|
||||||
|
Cli.Env {codebase} <- ask
|
||||||
|
baseLatestReleaseBranchObject <-
|
||||||
|
liftIO $
|
||||||
|
Codebase.expectBranchForHash
|
||||||
|
codebase
|
||||||
|
(Sync.Common.hash32ToCausalHash (Share.API.hashJWTHash (baseLatestReleaseBranch ^. #branchHead)))
|
||||||
|
pure (Just baseLatestReleaseBranchObject)
|
||||||
|
|
||||||
|
let reflogDescription =
|
||||||
|
case maybeProjectName of
|
||||||
|
Nothing -> "project.create"
|
||||||
|
Just projectName -> "project.create " <> into @Text projectName
|
||||||
|
|
||||||
|
let projectBranchObject =
|
||||||
|
case maybeBaseLatestReleaseBranchObject of
|
||||||
|
Nothing -> Branch.empty0
|
||||||
|
Just baseLatestReleaseBranchObject ->
|
||||||
|
let -- lib.base
|
||||||
|
projectBranchLibBaseObject =
|
||||||
|
over
|
||||||
|
Branch.children
|
||||||
|
(Map.insert (NameSegment "base") baseLatestReleaseBranchObject)
|
||||||
|
Branch.empty0
|
||||||
|
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||||
|
in over
|
||||||
|
Branch.children
|
||||||
|
(Map.insert Name.libSegment projectBranchLibObject)
|
||||||
|
Branch.empty0
|
||||||
|
|
||||||
|
Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
|
||||||
|
|
||||||
|
Cli.respond Output.HappyCoding
|
||||||
|
|
||||||
insertProjectAndBranch :: ProjectId -> ProjectName -> ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
insertProjectAndBranch :: ProjectId -> ProjectName -> ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
||||||
insertProjectAndBranch projectId projectName branchId branchName = do
|
insertProjectAndBranch projectId projectName branchId branchName = do
|
||||||
Queries.insertProject projectId projectName
|
Queries.insertProject projectId projectName
|
||||||
|
@ -5,6 +5,7 @@ module Unison.Codebase.Editor.HandleInput.Pull
|
|||||||
loadPropagateDiffDefaultPatch,
|
loadPropagateDiffDefaultPatch,
|
||||||
mergeBranchAndPropagateDefaultPatch,
|
mergeBranchAndPropagateDefaultPatch,
|
||||||
propagatePatch,
|
propagatePatch,
|
||||||
|
downloadShareProjectBranch,
|
||||||
withEntitiesDownloadedProgressCallback,
|
withEntitiesDownloadedProgressCallback,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -180,23 +181,28 @@ loadRemoteNamespaceIntoMemory syncMode pullMode remoteNamespace = do
|
|||||||
Cli.returnEarly (Output.GitError err)
|
Cli.returnEarly (Output.GitError err)
|
||||||
ReadShare'LooseCode repo -> loadShareLooseCodeIntoMemory repo
|
ReadShare'LooseCode repo -> loadShareLooseCodeIntoMemory repo
|
||||||
ReadShare'ProjectBranch remoteBranch -> do
|
ReadShare'ProjectBranch remoteBranch -> do
|
||||||
let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch (remoteBranch ^. #projectName) remoteProjectBranchName))
|
downloadShareProjectBranch remoteBranch
|
||||||
causalHash = Common.hash32ToCausalHash . Share.hashJWTHash $ causalHashJwt
|
let causalHash = Common.hash32ToCausalHash (Share.hashJWTHash (remoteBranch ^. #branchHead))
|
||||||
causalHashJwt = remoteBranch ^. #branchHead
|
liftIO (Codebase.expectBranchForHash codebase causalHash)
|
||||||
remoteProjectBranchName = remoteBranch ^. #branchName
|
|
||||||
(result, numDownloaded) <-
|
-- | @downloadShareProjectBranch branch@ downloads the given branch.
|
||||||
Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
downloadShareProjectBranch :: Share.RemoteProjectBranch -> Cli ()
|
||||||
result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback
|
downloadShareProjectBranch branch = do
|
||||||
numDownloaded <- liftIO getNumDownloaded
|
let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch (branch ^. #projectName) remoteProjectBranchName))
|
||||||
pure (result, numDownloaded)
|
causalHashJwt = branch ^. #branchHead
|
||||||
case result of
|
remoteProjectBranchName = branch ^. #branchName
|
||||||
Left err0 ->
|
exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt))
|
||||||
(Cli.returnEarly . Output.ShareError) case err0 of
|
when (not exists) do
|
||||||
Share.SyncError err -> Output.ShareErrorDownloadEntities err
|
(result, numDownloaded) <-
|
||||||
Share.TransportError err -> Output.ShareErrorTransport err
|
Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
|
||||||
Right () -> do
|
result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback
|
||||||
Cli.respond (Output.DownloadedEntities numDownloaded)
|
numDownloaded <- liftIO getNumDownloaded
|
||||||
liftIO (Codebase.expectBranchForHash codebase causalHash)
|
pure (result, numDownloaded)
|
||||||
|
result & onLeft \err0 -> do
|
||||||
|
(Cli.returnEarly . Output.ShareError) case err0 of
|
||||||
|
Share.SyncError err -> Output.ShareErrorDownloadEntities err
|
||||||
|
Share.TransportError err -> Output.ShareErrorTransport err
|
||||||
|
Cli.respond (Output.DownloadedEntities numDownloaded)
|
||||||
|
|
||||||
loadShareLooseCodeIntoMemory :: ReadShareLooseCode -> Cli (Branch IO)
|
loadShareLooseCodeIntoMemory :: ReadShareLooseCode -> Cli (Branch IO)
|
||||||
loadShareLooseCodeIntoMemory rrn@(ReadShareLooseCode {server, repo, path}) = do
|
loadShareLooseCodeIntoMemory rrn@(ReadShareLooseCode {server, repo, path}) = do
|
||||||
|
@ -373,6 +373,8 @@ data Output
|
|||||||
| RenamedProject ProjectName ProjectName
|
| RenamedProject ProjectName ProjectName
|
||||||
| RenamedProjectBranch ProjectName ProjectBranchName ProjectBranchName
|
| RenamedProjectBranch ProjectName ProjectBranchName ProjectBranchName
|
||||||
| CantRenameBranchTo ProjectBranchName
|
| CantRenameBranchTo ProjectBranchName
|
||||||
|
| FetchingLatestReleaseOfBase
|
||||||
|
| HappyCoding
|
||||||
|
|
||||||
-- | What did we create a project branch from?
|
-- | What did we create a project branch from?
|
||||||
--
|
--
|
||||||
@ -588,6 +590,8 @@ isFailure o = case o of
|
|||||||
RenamedProject {} -> False
|
RenamedProject {} -> False
|
||||||
RenamedProjectBranch {} -> False
|
RenamedProjectBranch {} -> False
|
||||||
CantRenameBranchTo {} -> True
|
CantRenameBranchTo {} -> True
|
||||||
|
FetchingLatestReleaseOfBase {} -> False
|
||||||
|
HappyCoding {} -> False
|
||||||
|
|
||||||
isNumberedFailure :: NumberedOutput -> Bool
|
isNumberedFailure :: NumberedOutput -> Bool
|
||||||
isNumberedFailure = \case
|
isNumberedFailure = \case
|
||||||
|
@ -43,6 +43,7 @@ import Unison.Auth.Types qualified as Auth
|
|||||||
import Unison.Builtin.Decls qualified as DD
|
import Unison.Builtin.Decls qualified as DD
|
||||||
import Unison.Cli.Pretty
|
import Unison.Cli.Pretty
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
|
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
|
||||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
|
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
import Unison.Codebase.Editor.Input qualified as Input
|
||||||
import Unison.Codebase.Editor.Output
|
import Unison.Codebase.Editor.Output
|
||||||
@ -1944,7 +1945,13 @@ notifyUser dir = \case
|
|||||||
P.text ("Unauthorized: " <> message)
|
P.text ("Unauthorized: " <> message)
|
||||||
ServantClientError err ->
|
ServantClientError err ->
|
||||||
pure case err of
|
pure case err of
|
||||||
Servant.ConnectionError _exception -> P.wrap "Something went wrong with the connection. Try again?"
|
Servant.ConnectionError exception ->
|
||||||
|
P.wrap $
|
||||||
|
fromMaybe "Something went wrong with the connection. Try again?" do
|
||||||
|
case ServantClientUtils.classifyConnectionError exception of
|
||||||
|
ServantClientUtils.ConnectionError'Offline -> Just "You appear to be offline."
|
||||||
|
ServantClientUtils.ConnectionError'SomethingElse _ -> Nothing
|
||||||
|
ServantClientUtils.ConnectionError'SomethingEntirelyUnexpected _ -> Nothing
|
||||||
Servant.DecodeFailure message response ->
|
Servant.DecodeFailure message response ->
|
||||||
P.wrap "Huh, I failed to decode a response from the server."
|
P.wrap "Huh, I failed to decode a response from the server."
|
||||||
<> P.newline
|
<> P.newline
|
||||||
@ -2092,6 +2099,32 @@ notifyUser dir = \case
|
|||||||
CantRenameBranchTo branch ->
|
CantRenameBranchTo branch ->
|
||||||
pure . P.wrap $
|
pure . P.wrap $
|
||||||
"You can't rename a branch to" <> P.group (prettyProjectBranchName branch <> ".")
|
"You can't rename a branch to" <> P.group (prettyProjectBranchName branch <> ".")
|
||||||
|
FetchingLatestReleaseOfBase ->
|
||||||
|
pure . P.wrap $
|
||||||
|
"I'll now fetch the latest version of the base Unison library..."
|
||||||
|
HappyCoding ->
|
||||||
|
pure $
|
||||||
|
P.wrap "🎨 Type `ui` to explore this project's code in your browser."
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap "🌏 Discover libraries at https://share.unison-lang.org"
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap "📖 Use `help-topic projects` to learn more about projects."
|
||||||
|
<> P.newline
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap "Write your first Unison code with UCM:"
|
||||||
|
<> P.newline
|
||||||
|
<> P.newline
|
||||||
|
<> P.indentN
|
||||||
|
2
|
||||||
|
( P.wrap "1. Open scratch.u."
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap "2. Write some Unison code and save the file."
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap "3. In UCM, type `add` to save it to your new project."
|
||||||
|
)
|
||||||
|
<> P.newline
|
||||||
|
<> P.newline
|
||||||
|
<> P.wrap "🎉 🥳 Happy coding!"
|
||||||
where
|
where
|
||||||
_nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo"
|
_nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo"
|
||||||
|
|
||||||
|
@ -37,6 +37,7 @@ library
|
|||||||
Unison.Cli.Pretty
|
Unison.Cli.Pretty
|
||||||
Unison.Cli.PrettyPrintUtils
|
Unison.Cli.PrettyPrintUtils
|
||||||
Unison.Cli.ProjectUtils
|
Unison.Cli.ProjectUtils
|
||||||
|
Unison.Cli.ServantClientUtils
|
||||||
Unison.Cli.Share.Projects
|
Unison.Cli.Share.Projects
|
||||||
Unison.Cli.Share.Projects.Types
|
Unison.Cli.Share.Projects.Types
|
||||||
Unison.Cli.TypeCheck
|
Unison.Cli.TypeCheck
|
||||||
@ -132,6 +133,7 @@ library
|
|||||||
InstanceSigs
|
InstanceSigs
|
||||||
LambdaCase
|
LambdaCase
|
||||||
MultiParamTypeClasses
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
NamedFieldPuns
|
NamedFieldPuns
|
||||||
NumericUnderscores
|
NumericUnderscores
|
||||||
OverloadedLabels
|
OverloadedLabels
|
||||||
@ -261,6 +263,7 @@ executable cli-integration-tests
|
|||||||
InstanceSigs
|
InstanceSigs
|
||||||
LambdaCase
|
LambdaCase
|
||||||
MultiParamTypeClasses
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
NamedFieldPuns
|
NamedFieldPuns
|
||||||
NumericUnderscores
|
NumericUnderscores
|
||||||
OverloadedLabels
|
OverloadedLabels
|
||||||
@ -390,6 +393,7 @@ executable transcripts
|
|||||||
InstanceSigs
|
InstanceSigs
|
||||||
LambdaCase
|
LambdaCase
|
||||||
MultiParamTypeClasses
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
NamedFieldPuns
|
NamedFieldPuns
|
||||||
NumericUnderscores
|
NumericUnderscores
|
||||||
OverloadedLabels
|
OverloadedLabels
|
||||||
@ -523,6 +527,7 @@ executable unison
|
|||||||
InstanceSigs
|
InstanceSigs
|
||||||
LambdaCase
|
LambdaCase
|
||||||
MultiParamTypeClasses
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
NamedFieldPuns
|
NamedFieldPuns
|
||||||
NumericUnderscores
|
NumericUnderscores
|
||||||
OverloadedLabels
|
OverloadedLabels
|
||||||
@ -662,6 +667,7 @@ test-suite cli-tests
|
|||||||
InstanceSigs
|
InstanceSigs
|
||||||
LambdaCase
|
LambdaCase
|
||||||
MultiParamTypeClasses
|
MultiParamTypeClasses
|
||||||
|
MultiWayIf
|
||||||
NamedFieldPuns
|
NamedFieldPuns
|
||||||
NumericUnderscores
|
NumericUnderscores
|
||||||
OverloadedLabels
|
OverloadedLabels
|
||||||
|
Loading…
Reference in New Issue
Block a user