mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
more project.push work
This commit is contained in:
parent
e110d96dc4
commit
9eec421ae8
@ -102,6 +102,7 @@ module U.Codebase.Sqlite.Queries
|
||||
Project (..),
|
||||
projectExists,
|
||||
projectExistsByName,
|
||||
expectProject,
|
||||
loadProjectByName,
|
||||
insertProject,
|
||||
Branch (..),
|
||||
@ -2512,18 +2513,22 @@ projectExistsByName name =
|
||||
|
||||
-- FIXME rename loadProject
|
||||
getProject :: ProjectId -> Transaction (Maybe Project)
|
||||
getProject pid = queryMaybeRow bonk (Only pid)
|
||||
where
|
||||
bonk =
|
||||
[sql|
|
||||
SELECT
|
||||
id,
|
||||
name
|
||||
FROM
|
||||
project
|
||||
WHERE
|
||||
id = ?
|
||||
|]
|
||||
getProject pid = queryMaybeRow loadProjectSql (Only pid)
|
||||
|
||||
expectProject :: ProjectId -> Transaction Project
|
||||
expectProject pid = queryOneRow loadProjectSql (Only pid)
|
||||
|
||||
loadProjectSql :: Sql
|
||||
loadProjectSql =
|
||||
[sql|
|
||||
SELECT
|
||||
id,
|
||||
name
|
||||
FROM
|
||||
project
|
||||
WHERE
|
||||
id = ?
|
||||
|]
|
||||
|
||||
loadProjectByName :: Text -> Transaction (Maybe Project)
|
||||
loadProjectByName name =
|
||||
|
@ -32,98 +32,6 @@ create table project_branch_parent (
|
||||
)
|
||||
without rowid;
|
||||
|
||||
-- create table project_branch_default_pull (
|
||||
-- local_project_id uuid not null references project (id),
|
||||
-- local_branch_id uuid not null,
|
||||
-- named_remote_name text null,
|
||||
-- named_remote_project_id text null,
|
||||
-- named_remote_host text null,
|
||||
-- unnamed_remote_project_id text null,
|
||||
-- unnamed_remote_host text null,
|
||||
-- remote_branch_id text null,
|
||||
--
|
||||
-- primary key (local_project_id, local_branch_id),
|
||||
--
|
||||
-- foreign key (local_project_id, local_branch_id)
|
||||
-- references project_branch (project_id, id)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- foreign key (local_project_id, named_remote_project_id, named_remote_host, named_remote_name)
|
||||
-- references project_remote_alias (local_project_id, remote_project_id, remote_host, remote_name)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- foreign key (named_remote_project_id, remote_branch_id, named_remote_host)
|
||||
-- references remote_project_branch (project_id, branch_id, host)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- foreign key (unnamed_remote_project_id, remote_branch_id, unnamed_remote_host)
|
||||
-- references remote_project_branch (project_id, branch_id, host)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- constraint valid_remote_project check (
|
||||
-- ( named_remote_name is not null
|
||||
-- and named_remote_project_id is not null
|
||||
-- and named_remote_host is not null
|
||||
-- and unnamed_remote_project_id is null
|
||||
-- and unnamed_remote_host is null
|
||||
-- )
|
||||
-- or
|
||||
-- ( named_remote_name is null
|
||||
-- and named_remote_project_id is null
|
||||
-- and named_remote_host is null
|
||||
-- and unnamed_remote_project_id is not null
|
||||
-- and unnamed_remote_host is not null
|
||||
-- )
|
||||
-- )
|
||||
-- )
|
||||
-- without rowid;
|
||||
|
||||
-- create table project_branch_default_push (
|
||||
-- local_project_id uuid not null references project (id),
|
||||
-- local_branch_id uuid not null,
|
||||
-- named_remote_name text null,
|
||||
-- named_remote_project_id text null,
|
||||
-- named_remote_host text null,
|
||||
-- unnamed_remote_project_id text null,
|
||||
-- unnamed_remote_host text null,
|
||||
-- remote_branch_id text null,
|
||||
--
|
||||
-- primary key (local_project_id, local_branch_id),
|
||||
--
|
||||
-- foreign key (local_project_id, local_branch_id)
|
||||
-- references project_branch (project_id, id)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- foreign key (local_project_id, named_remote_project_id, named_remote_host, named_remote_name)
|
||||
-- references project_remote_alias (local_project_id, remote_project_id, remote_host, remote_name)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- foreign key (named_remote_project_id, remote_branch_id, named_remote_host)
|
||||
-- references remote_project_branch (project_id, branch_id, host)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- foreign key (unnamed_remote_project_id, remote_branch_id, unnamed_remote_host)
|
||||
-- references remote_project_branch (project_id, branch_id, host)
|
||||
-- on delete cascade,
|
||||
--
|
||||
-- constraint valid_remote_project check (
|
||||
-- ( named_remote_name is not null
|
||||
-- and named_remote_project_id is not null
|
||||
-- and named_remote_host is not null
|
||||
-- and unnamed_remote_project_id is null
|
||||
-- and unnamed_remote_host is null
|
||||
-- )
|
||||
-- or
|
||||
-- ( named_remote_name is null
|
||||
-- and named_remote_project_id is null
|
||||
-- and named_remote_host is null
|
||||
-- and unnamed_remote_project_id is not null
|
||||
-- and unnamed_remote_host is not null
|
||||
-- )
|
||||
-- )
|
||||
-- )
|
||||
-- without rowid;
|
||||
|
||||
create table project_branch_remote_mapping (
|
||||
local_project_id uuid not null references project (id),
|
||||
local_branch_id uuid not null,
|
||||
|
@ -64,6 +64,7 @@ dependencies:
|
||||
- servant-client
|
||||
- stm
|
||||
- text
|
||||
- text-builder
|
||||
- text-rope
|
||||
- these
|
||||
- time
|
||||
|
@ -15,7 +15,6 @@ import qualified Unison.Codebase.Branch as Branch
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectName)
|
||||
import Witch
|
||||
|
||||
-- | Create a new project.
|
||||
--
|
||||
|
@ -13,7 +13,6 @@ import Unison.Cli.ProjectUtils (getCurrentProjectBranch, projectBranchPath)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectBranchName)
|
||||
import Witch (into)
|
||||
|
||||
-- | Create a new branch in a project:
|
||||
--
|
||||
|
@ -6,12 +6,18 @@ where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Data.Text as Text
|
||||
import Data.Text.IO as Text
|
||||
import qualified Text.Builder
|
||||
import qualified U.Codebase.Sqlite.Queries as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import qualified Unison.Cli.Monad as Cli
|
||||
import Unison.Cli.ProjectUtils (getCurrentProjectBranch, loggeth)
|
||||
import qualified Unison.Cli.Share.Projects as Share
|
||||
import qualified Unison.Codebase.Editor.HandleInput.AuthLogin as AuthLogin
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, classifyProjectName)
|
||||
import qualified Unison.Share.API.Projects as Share.API
|
||||
import qualified Unison.Share.Codeserver as Codeserver
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
-- | Push a project branch.
|
||||
@ -45,18 +51,64 @@ projectPush maybeProjectAndBranch = do
|
||||
|
||||
case maybeProjectAndBranch of
|
||||
Nothing -> do
|
||||
maybeRemoteIds <- undefined :: Cli (Either Text (Text, Text))
|
||||
case maybeRemoteIds of
|
||||
Left ancestorRemoteProjectId -> do
|
||||
loggeth ["We don't have a remote branch mapping, but our ancestor maps to project: ", ancestorRemoteProjectId]
|
||||
loggeth ["Creating remote branch not implemented"]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
Right (remoteProjectId, remoteBranchId) -> do
|
||||
loggeth ["Found remote branch mapping: ", remoteProjectId, ":", remoteBranchId]
|
||||
loggeth ["Pushing to existing branch not implemented"]
|
||||
Cli.runTransaction oinkResolveRemoteIds >>= \case
|
||||
Nothing -> do
|
||||
loggeth ["We don't have a remote branch mapping for this branch or any ancestor"]
|
||||
loggeth ["Getting current logged-in user on Share"]
|
||||
myUserHandle <- oinkGetLoggedInUser
|
||||
loggeth ["Got current logged-in user on Share: ", myUserHandle]
|
||||
project <- Cli.runTransaction (Queries.expectProject projectId)
|
||||
let localProjectName = unsafeFrom @Text (project ^. #name)
|
||||
let remoteProjectName =
|
||||
case classifyProjectName localProjectName of
|
||||
(Nothing, name) ->
|
||||
Text.Builder.run $
|
||||
Text.Builder.char '@'
|
||||
<> Text.Builder.text myUserHandle
|
||||
<> Text.Builder.char '/'
|
||||
<> Text.Builder.text name
|
||||
(Just _, _) -> into @Text localProjectName
|
||||
loggeth ["Making create-project request for project", remoteProjectName]
|
||||
response <-
|
||||
Share.createProject Share.API.CreateProjectRequest {projectName = remoteProjectName} & onLeftM \err -> do
|
||||
loggeth ["Creating a project failed"]
|
||||
loggeth [tShow err]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
remoteProject <-
|
||||
case response of
|
||||
Share.API.CreateProjectResponseBadRequest -> do
|
||||
loggeth ["Share says: bad request"]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
Share.API.CreateProjectResponseUnauthorized -> do
|
||||
loggeth ["Share says: unauthorized"]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
Share.API.CreateProjectResponseSuccess remoteProject -> pure remoteProject
|
||||
loggeth ["Share says: success!"]
|
||||
loggeth [tShow remoteProject]
|
||||
-- TODO push this branch
|
||||
Cli.returnEarlyWithoutOutput
|
||||
Just projectAndBranch ->
|
||||
case projectAndBranch ^. #branch of
|
||||
Nothing -> do
|
||||
let ancestorRemoteProjectId = projectAndBranch ^. #project
|
||||
loggeth ["We don't have a remote branch mapping, but our ancestor maps to project: ", ancestorRemoteProjectId]
|
||||
loggeth ["Creating remote branch not implemented"]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
Just remoteBranchId -> do
|
||||
let remoteProjectId = projectAndBranch ^. #project
|
||||
loggeth ["Found remote branch mapping: ", remoteProjectId, ":", remoteBranchId]
|
||||
loggeth ["Pushing to existing branch not implemented"]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
Just projectAndBranch -> do
|
||||
let _projectName = projectAndBranch ^. #project
|
||||
let _branchName = fromMaybe (unsafeFrom @Text "main") (projectAndBranch ^. #branch)
|
||||
loggeth ["Specifying project/branch to push to not implemented"]
|
||||
Cli.returnEarlyWithoutOutput
|
||||
|
||||
oinkResolveRemoteIds :: Sqlite.Transaction (Maybe (ProjectAndBranch Text (Maybe Text)))
|
||||
oinkResolveRemoteIds = undefined
|
||||
|
||||
oinkGetLoggedInUser :: Cli Text
|
||||
oinkGetLoggedInUser = do
|
||||
AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
|
||||
wundefined
|
||||
|
@ -49,7 +49,6 @@ import qualified Unison.Syntax.Name as Name (unsafeFromString)
|
||||
import qualified Unison.Util.ColorText as CT
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import qualified Unison.Util.Pretty as P
|
||||
import Witch
|
||||
|
||||
showPatternHelp :: InputPattern -> P.Pretty CT.ColorText
|
||||
showPatternHelp i =
|
||||
|
@ -38,7 +38,6 @@ import Data.Set.NonEmpty (NESet)
|
||||
import qualified Data.Set.NonEmpty as NESet
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
import qualified Data.Text.Lazy.Encoding as Text.Lazy
|
||||
import Data.Void (Void)
|
||||
import qualified Ki
|
||||
import qualified Network.HTTP.Client as Http.Client
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
|
@ -184,6 +184,7 @@ library
|
||||
, servant-client
|
||||
, stm
|
||||
, text
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, time
|
||||
@ -315,6 +316,7 @@ executable cli-integration-tests
|
||||
, shellmet
|
||||
, stm
|
||||
, text
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, time
|
||||
@ -439,6 +441,7 @@ executable transcripts
|
||||
, shellmet
|
||||
, stm
|
||||
, text
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, time
|
||||
@ -571,6 +574,7 @@ executable unison
|
||||
, template-haskell
|
||||
, temporary
|
||||
, text
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, time
|
||||
@ -706,6 +710,7 @@ test-suite cli-tests
|
||||
, stm
|
||||
, temporary
|
||||
, text
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, time
|
||||
|
@ -4,6 +4,7 @@
|
||||
-- package, but for now we have just defined the one blessed project/branch name syntax that we allow.
|
||||
module Unison.Project
|
||||
( ProjectName,
|
||||
classifyProjectName,
|
||||
ProjectBranchName,
|
||||
ProjectAndBranch (..),
|
||||
)
|
||||
@ -32,16 +33,10 @@ instance TryFrom Text ProjectName where
|
||||
|
||||
projectNameParser :: Megaparsec.Parsec Void Text ProjectName
|
||||
projectNameParser = do
|
||||
userPrefix <- userPrefixParser <|> pure mempty
|
||||
userSlug <- userSlugParser <|> pure mempty
|
||||
projectSlug <- projectSlugParser
|
||||
pure (ProjectName (Text.Builder.run (userPrefix <> projectSlug)))
|
||||
pure (ProjectName (Text.Builder.run (userSlug <> projectSlug)))
|
||||
where
|
||||
userPrefixParser :: Megaparsec.Parsec Void Text Text.Builder
|
||||
userPrefixParser = do
|
||||
userSlug <- userSlugParser
|
||||
slash <- Megaparsec.char '/'
|
||||
pure (userSlug <> Text.Builder.char slash)
|
||||
|
||||
projectSlugParser :: Megaparsec.Parsec Void Text Text.Builder
|
||||
projectSlugParser = do
|
||||
c0 <- Megaparsec.satisfy isStartChar
|
||||
@ -52,6 +47,16 @@ projectNameParser = do
|
||||
isStartChar c =
|
||||
Char.isAlpha c || c == '_'
|
||||
|
||||
-- | Given a valid project name, "classify" it as beginning with a user slug, or not.
|
||||
--
|
||||
-- >>> classifyProjectName "lens"
|
||||
-- (Nothing, "lens")
|
||||
--
|
||||
-- >>> classifyProjectName "@arya/lens"
|
||||
-- (Just "arya", "lens")
|
||||
classifyProjectName :: ProjectName -> (Maybe Text, Text)
|
||||
classifyProjectName (ProjectName name) = undefined
|
||||
|
||||
-- | The name of a branch of a project.
|
||||
--
|
||||
-- Convert to and from text with the 'From' and 'TryFrom' instances.
|
||||
@ -67,16 +72,10 @@ instance TryFrom Text ProjectBranchName where
|
||||
|
||||
projectBranchNameParser :: Megaparsec.Parsec Void Text ProjectBranchName
|
||||
projectBranchNameParser = do
|
||||
userPrefix <- userPrefixParser <|> pure mempty
|
||||
userSlug <- userSlugParser <|> pure mempty
|
||||
branchSlug <- branchSlugParser
|
||||
pure (ProjectBranchName (Text.Builder.run (userPrefix <> branchSlug)))
|
||||
pure (ProjectBranchName (Text.Builder.run (userSlug <> branchSlug)))
|
||||
where
|
||||
userPrefixParser :: Megaparsec.Parsec Void Text Text.Builder
|
||||
userPrefixParser = do
|
||||
userSlug <- userSlugParser
|
||||
colon <- Megaparsec.char ':'
|
||||
pure (userSlug <> Text.Builder.char colon)
|
||||
|
||||
branchSlugParser :: Megaparsec.Parsec Void Text Text.Builder
|
||||
branchSlugParser = do
|
||||
c0 <- Megaparsec.satisfy isStartChar
|
||||
@ -94,10 +93,10 @@ data ProjectAndBranch a b = ProjectAndBranch
|
||||
}
|
||||
deriving stock (Eq, Generic, Show)
|
||||
|
||||
-- | @project:branch@ syntax for project+branch pair, with both sides optional. Missing value means "the current one".
|
||||
-- | @project/branch@ syntax for project+branch pair, with both sides optional. Missing value means "the current one".
|
||||
instance From (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) Text where
|
||||
from ProjectAndBranch {project, branch} =
|
||||
Text.Builder.run (textify project <> Text.Builder.char ':' <> textify branch)
|
||||
Text.Builder.run (textify project <> Text.Builder.char '/' <> textify branch)
|
||||
where
|
||||
textify :: From thing Text => Maybe thing -> Text.Builder
|
||||
textify =
|
||||
@ -114,15 +113,15 @@ projectAndBranchNamesParser ::
|
||||
(ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
|
||||
projectAndBranchNamesParser = do
|
||||
project <- optional projectNameParser
|
||||
_ <- Megaparsec.char ':'
|
||||
_ <- Megaparsec.char '/'
|
||||
branch <- optional projectBranchNameParser
|
||||
pure ProjectAndBranch {project, branch}
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
-- Projects and branches may begin with a "user slug", which looks like "@arya".
|
||||
-- Projects and branches may begin with a "user slug", which looks like "@arya/".
|
||||
--
|
||||
-- slug = @ start-char char*
|
||||
-- slug = @ start-char char* /
|
||||
-- start-char = alpha | _
|
||||
-- char = start-char | -
|
||||
userSlugParser :: Megaparsec.Parsec Void Text Text.Builder.Builder
|
||||
@ -130,7 +129,8 @@ userSlugParser = do
|
||||
c0 <- Megaparsec.char '@'
|
||||
c1 <- Megaparsec.satisfy isStartChar
|
||||
c2 <- Megaparsec.takeWhileP Nothing (\c -> isStartChar c || c == '-')
|
||||
pure (Text.Builder.char c0 <> Text.Builder.char c1 <> Text.Builder.text c2)
|
||||
c3 <- Megaparsec.char '/'
|
||||
pure (Text.Builder.char c0 <> Text.Builder.char c1 <> Text.Builder.text c2 <> Text.Builder.char c3)
|
||||
where
|
||||
isStartChar :: Char -> Bool
|
||||
isStartChar c =
|
||||
|
Loading…
Reference in New Issue
Block a user