Merge branch 'gitlab'

6 files changed, 83 insertions, 23 deletions

diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index 75a266fa2..e847edd39 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -34,7 +34,7 @@ setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pai
  - the host we paired with. -}
 finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
 finishedLocalPairing msg keypair = do
-	sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
+	sshdata <- liftIO $ installSshKeyPair keypair =<< pairMsgToSshData msg
 	{- Ensure that we know the ssh host key for the host we paired with.
 	 - If we don't, ssh over to get it. -}
 	liftIO $ unlessM (knownHost $ sshHostName sshdata) $
@@ -69,6 +69,7 @@ pairMsgToSshData msg = do
 		, sshPort = 22
 		, needsPubKey = True
 		, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
+		, sshRepoUrl = Nothing
 		}
 
 {- Finds the best hostname to use for the host that sent the PairMsg.
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 88afec713..80fb5c19a 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -28,28 +28,37 @@ data SshData = SshData
 	, sshPort :: Int
 	, needsPubKey :: Bool
 	, sshCapabilities :: [SshServerCapability]
+	, sshRepoUrl :: Maybe String
 	}
 	deriving (Read, Show, Eq)
 
-data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
+data SshServerCapability
+	= GitAnnexShellCapable -- server has git-annex-shell installed
+	| GitCapable -- server has git installed
+	| RsyncCapable -- server supports raw rsync access (not only via git-annex-shell)
+	| PushCapable -- repo on server is set up already, and ready to accept pushes
 	deriving (Read, Show, Eq)
 
 hasCapability :: SshData -> SshServerCapability -> Bool
 hasCapability d c = c `elem` sshCapabilities d
 
+addCapability :: SshData -> SshServerCapability -> SshData
+addCapability d c = d { sshCapabilities = c : sshCapabilities d }
+
 onlyCapability :: SshData -> SshServerCapability -> Bool
 onlyCapability d c = all (== c) (sshCapabilities d)
 
+type SshPubKey = String
+type SshPrivKey = String
+
 data SshKeyPair = SshKeyPair
-	{ sshPubKey :: String
-	, sshPrivKey :: String
+	{ sshPubKey :: SshPubKey
+	, sshPrivKey :: SshPrivKey
 	}
 
 instance Show SshKeyPair where
 	show = sshPubKey
 
-type SshPubKey = String
-
 {- ssh -ofoo=bar command-line option -}
 sshOpt :: String -> String -> String
 sshOpt k v = concat ["-o", k, "=", v]
@@ -60,10 +69,12 @@ genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
 
 {- Generates a ssh or rsync url from a SshData. -}
 genSshUrl :: SshData -> String
-genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $
-	if (onlyCapability sshdata RsyncCapable)
-		then [u, h, T.pack ":", sshDirectory sshdata]
-		else [T.pack "ssh://", u, h, d]
+genSshUrl sshdata = case sshRepoUrl sshdata of
+	Just repourl -> repourl
+	Nothing -> addtrailingslash $ T.unpack $ T.concat $
+		if (onlyCapability sshdata RsyncCapable)
+			then [u, h, T.pack ":", sshDirectory sshdata]
+			else [T.pack "ssh://", u, h, d]
   where
 	u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
 	h = sshHostName sshdata
@@ -90,6 +101,7 @@ parseSshUrl u
 		, sshPort = 22
 		, needsPubKey = True
 		, sshCapabilities = []
+		, sshRepoUrl = Nothing
 		}
 	  where
 		(user, host) = if '@' `elem` userhost
@@ -222,24 +234,44 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
  - when git-annex and git try to access the remote, if its
  - host key has changed.
  -}
-setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
-setupSshKeyPair sshkeypair sshdata = do
+installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
+installSshKeyPair sshkeypair sshdata = do
 	sshdir <- sshDir
-	createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
+	createDirectoryIfMissing True $ parentDir $ sshdir </> sshPrivKeyFile sshdata
 
-	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
-		writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)
-	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
-		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
+	unlessM (doesFileExist $ sshdir </> sshPrivKeyFile sshdata) $
+		writeFileProtected (sshdir </> sshPrivKeyFile sshdata) (sshPrivKey sshkeypair)
+	unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
+		writeFile (sshdir </> sshPubKeyFile sshdata) (sshPubKey sshkeypair)
 
 	setSshConfig sshdata
-		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
+		[ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata)
 		, ("IdentitiesOnly", "yes")
 		, ("StrictHostKeyChecking", "yes")
 		]
-  where
-	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
-	sshpubkeyfile = sshprivkeyfile ++ ".pub"
+
+sshPrivKeyFile :: SshData -> FilePath
+sshPrivKeyFile sshdata = "git-annex" </> "key." ++ mangleSshHostName sshdata
+
+sshPubKeyFile :: SshData -> FilePath
+sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub"
+
+{- Generates an installs a new ssh key pair if one is not already
+ - installed. Returns the modified SshData that will use the key pair,
+ - and the key pair. -}
+setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair)
+setupSshKeyPair sshdata = do
+	sshdir <- sshDir
+	mprivkey <- catchMaybeIO $ readFile (sshdir </> sshPrivKeyFile sshdata)
+	mpubkey <- catchMaybeIO $ readFile (sshdir </> sshPubKeyFile sshdata)
+	keypair <- case (mprivkey, mpubkey) of
+		(Just privkey, Just pubkey) -> return $ SshKeyPair
+			{ sshPubKey = pubkey
+			, sshPrivKey = privkey
+			}
+		_ -> genSshKeyPair
+	sshdata' <- installSshKeyPair keypair sshdata
+	return (sshdata', keypair)
 
 {- Fixes git-annex ssh key pairs configured in .ssh/config 
  - by old versions to set IdentitiesOnly.
@@ -293,11 +325,16 @@ setSshConfig sshdata config = do
 				(settings ++ config)
 		setSshConfigMode configfile
 
-	return $ sshdata { sshHostName = T.pack mangledhost }
+	return $ sshdata
+		{ sshHostName = T.pack mangledhost
+		, sshRepoUrl = replace orighost mangledhost
+			<$> sshRepoUrl sshdata
+		}
   where
+	orighost = T.unpack $ sshHostName sshdata
 	mangledhost = mangleSshHostName sshdata
 	settings =
-		[ ("Hostname", T.unpack $ sshHostName sshdata)
+		[ ("Hostname", orighost)
 		, ("Port", show $ sshPort sshdata)
 		]
 
diff --git a/debian/changelog b/debian/changelog
index c7debba53..2c3b509e5 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -27,6 +27,7 @@ git-annex (5.20150714) UNRELEASED; urgency=medium
     permalinks in rss feeds, it now also looks at guids.
   * importfeed: Look at not only permalinks, but now also guids
     to identify previously downloaded files.
+  * Webapp: Now features easy setup of git-annex repositories on gitlab.com.
   * Adjust debian build deps: The webapp can now build on arm64, s390x
     and hurd-i386. WebDAV support is also available on those architectures.
   * Debian package now maintained by Richard Hartmann.
diff --git a/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn b/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn
new file mode 100644
index 000000000..e04a8068d
--- /dev/null
+++ b/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn
@@ -0,0 +1,6 @@
+Enabling a gitlab repo that was set up elsewhere in the webapp doesn't
+work.
+
+This is a SMOP; it needs to detect that the repo is on gitlab and use a
+custom enabling process and no the generic one, which doesn't work.
+--[[Joey]]
diff --git a/doc/bugs/gitlab_repos_cannot_use_gcrypt.mdwn b/doc/bugs/gitlab_repos_cannot_use_gcrypt.mdwn
new file mode 100644
index 000000000..06ea255d0
--- /dev/null
+++ b/doc/bugs/gitlab_repos_cannot_use_gcrypt.mdwn
@@ -0,0 +1,12 @@
+It's not possible to use gcrypt with gitlab repos, despite the webapp
+currently offering this as an option. The resulting remote works as far as
+pushes go, but fails with an error "Failed to connect to remote to set it
+up."
+
+It seems that the gitlab repo is somehow in a state where git-annex-shell
+configlist reports it's not yet a git-annex repo, but git-annex-shell
+gcryptsetup fails with "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
+
+This does not happen when I try the same setup on a self-hosted repo.
+Unsure what is causing git-annex-shell to behave this way on gitlab.
+--[[Joey]]
diff --git a/doc/todo/Add_gitlab.com_as_cloud_provider.mdwn b/doc/todo/Add_gitlab.com_as_cloud_provider.mdwn
index 33c5c7188..65c14b736 100644
--- a/doc/todo/Add_gitlab.com_as_cloud_provider.mdwn
+++ b/doc/todo/Add_gitlab.com_as_cloud_provider.mdwn
@@ -5,3 +5,6 @@ Hi,
 Gitlab.com and Gitlab enterprise edition, but unfortunately not Gitlab community edition, now [provides git annex support](https://about.gitlab.com/2015/02/17/gitlab-annex-solves-the-problem-of-versioning-large-binaries-with-git/).  It works fairly based for the repos I have enabled it on.  At the moment it's free, but one may have to pay for repos larger than 5Gb [in the future](https://about.gitlab.com/2015/02/22/gitlab-7-8-released/#comment-1870271594).
 
 Perhaps gitlab.com should be added to preconfigured cloud providers?
+
+> [[done]] although there are a few known bugs in the webapp's
+> implementation. --[[Joey]]