more project.push work

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -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 =

codebase2/codebase-sqlite/sql/004-project-tables.sql

@@ -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,

unison-cli/package.yaml

@@ -64,6 +64,7 @@ dependencies:
   - servant-client
   - stm
   - text
+  - text-builder
   - text-rope
   - these
   - time

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

@@ -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.
 --

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

@@ -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:
 --

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

@@ -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

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

@@ -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 =

unison-cli/src/Unison/Share/Sync.hs

@@ -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

unison-cli/unison-cli.cabal

@@ -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

unison-core/src/Unison/Project.hs

@@ -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 =