basic gitlab support in webapp

This works, but needs more testing and work on cases like encrypted repos,
enabling existing repositories, etc.

This commit was sponsored by Shaun Westmacott.

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.

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.

Assistant/WebApp/Configurators/Ssh.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant webapp configurator for ssh-based remotes
  -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -21,8 +21,13 @@ import Types.StandardGroups
 import Utility.UserInfo
 import Utility.Gpg
 import Types.Remote (RemoteConfig)
-import Git.Types (RemoteName)
+import Git.Types (RemoteName, fromRef)
 import qualified Remote.GCrypt as GCrypt
+import qualified Git.Construct
+import qualified Git.Config
+import qualified Git.Command
+import qualified Remote.Helper.Ssh
+import qualified Annex.Branch
 import Annex.UUID
 import Logs.UUID
 import Assistant.RemoteControl
@@ -74,6 +79,7 @@ mkSshData s = SshData
 	, sshPort = inputPort s
 	, needsPubKey = False
 	, sshCapabilities = [] -- untested
+	, sshRepoUrl = Nothing
 	}
 
 mkSshInput :: SshData -> SshInput
@@ -137,6 +143,7 @@ sshInputAForm hostnamefield d = normalize <$> gen
 data ServerStatus
 	= UntestedServer
 	| UnusableServer Text -- reason why it's not usable
+	| ServerNeedsPubKey SshPubKey
 	| UsableServer [SshServerCapability]
 	deriving (Eq)
 
@@ -486,8 +493,7 @@ combineExistingGCrypt sshdata u = do
 prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
 prepSsh needsinit sshdata a
 	| needsPubKey sshdata = do
-		keypair <- liftIO genSshKeyPair
-		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
+		(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
 		prepSsh' needsinit sshdata sshdata' (Just keypair) a
 	| sshPort sshdata /= 22 = do
 		sshdata' <- liftIO $ setSshConfig sshdata []
@@ -495,11 +501,13 @@ prepSsh needsinit sshdata a
 	| otherwise = prepSsh' needsinit sshdata sshdata Nothing a
 
 prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
-prepSsh' needsinit origsshdata sshdata keypair a = sshSetup (mkSshInput origsshdata)
-	 [ "-p", show (sshPort origsshdata)
-	 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
-	 , remoteCommand
-	 ] Nothing (a sshdata)
+prepSsh' needsinit origsshdata sshdata keypair a
+	| hasCapability sshdata PushCapable = a sshdata
+	| otherwise = sshSetup (mkSshInput origsshdata)
+		 [ "-p", show (sshPort origsshdata)
+		 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
+		 , remoteCommand
+		 ] Nothing (a sshdata)
   where
 	remotedir = T.unpack $ sshDirectory sshdata
 	remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
@@ -628,8 +636,7 @@ enableRsyncNetGCrypt sshinput reponame =
 prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
 prepRsyncNet sshinput reponame a = do
 	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
-	keypair <- liftIO genSshKeyPair
-	sshdata <- liftIO $ setupSshKeyPair keypair $
+	(sshdata, keypair) <- liftIO $ setupSshKeyPair $
 		(mkSshData sshinput)
 			{ sshRepoName = reponame 
 			, needsPubKey = True
@@ -654,3 +661,86 @@ prepRsyncNet sshinput reponame a = do
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False
 isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
+
+data GitLabUrl = GitLabUrl Text
+
+badGitLabUrl :: Text
+badGitLabUrl = "Bad SSH clone url. Expected something like: git@gitlab.com:yourlogin/annex.git"
+
+parseGitLabUrl :: GitLabUrl -> Maybe SshData
+parseGitLabUrl (GitLabUrl t) = 
+	let (u, r) = separate (== '@') (T.unpack t)
+	    (h, p) = separate (== ':') r
+	in if null u || null h || null p
+		then Nothing
+		else Just $ SshData
+			{ sshHostName = T.pack h
+			, sshUserName = Just (T.pack u)
+			, sshDirectory = T.pack p
+			, sshRepoName = genSshRepoName h p
+			, sshPort = 22
+			, needsPubKey = False
+			, sshCapabilities = 
+				[ GitAnnexShellCapable
+				, GitCapable
+				, PushCapable
+				]
+			, sshRepoUrl = Just (T.unpack t)
+			}
+
+{- Try to ssh into the gitlab server, verify we can access the repository,
+ - and get the uuid of the repository, if it already has one.
+ -
+ - A repository on gitlab won't be initialized as a git-annex repo 
+ - unless a git-annex branch was already pushed to it. So, if
+ - git-annex-shell fails to work that's probably why; verify if
+ - the server is letting us ssh in by running git send-pack
+ - (in dry run mode). -}
+testGitLabUrl :: GitLabUrl -> Annex (ServerStatus, Maybe SshData, UUID)
+testGitLabUrl glu = case parseGitLabUrl glu of
+	Nothing -> return (UnusableServer badGitLabUrl, Nothing, NoUUID)
+	Just sshdata -> do
+		u <- probeuuid sshdata
+		if u /= NoUUID
+			then return (UsableServer (sshCapabilities sshdata), Just sshdata, u)
+			else ifM (verifysshworks sshdata)
+				( return (UsableServer (sshCapabilities sshdata), Just sshdata, NoUUID)
+				, do
+					(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
+					return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID)
+				)
+  where
+	probeuuid sshdata = do
+		r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata)
+		getUncachedUUID . either (const r) fst <$>
+			Remote.Helper.Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] []
+	verifysshworks sshdata = inRepo $ Git.Command.runBool
+		[ Param "send-pack"
+		, Param (fromJust $ sshRepoUrl sshdata)
+		, Param "--dry-run"
+		, Param "--force"
+		, Param (fromRef Annex.Branch.name)
+		]
+
+gitLabUrlAForm :: AForm Handler GitLabUrl
+gitLabUrlAForm = GitLabUrl <$> areq check_input (bfs "SSH clone url") Nothing
+  where
+	check_input = checkBool (isJust . parseGitLabUrl . GitLabUrl)
+		badGitLabUrl textField
+
+getAddGitLabR :: Handler Html
+getAddGitLabR = postAddGitLabR
+postAddGitLabR :: Handler Html
+postAddGitLabR = sshConfigurator $ do
+	((result, form), enctype) <- liftH $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout gitLabUrlAForm
+	case result of
+		FormSuccess gitlaburl -> do
+			(status, msshdata, u) <- liftAnnex $ testGitLabUrl gitlaburl
+			case (status, msshdata) of
+				(UsableServer _, Just sshdata) ->
+					liftH $ redirect $ ConfirmSshR sshdata u
+				_ -> showform form enctype status
+		_ -> showform form enctype UntestedServer
+  where
+	showform form enctype status = $(widgetFile "configurators/gitlab.com/add")

Assistant/WebApp/routes

@@ -61,6 +61,7 @@
 /config/repository/add/cloud/IA AddIAR GET POST
 /config/repository/add/cloud/glacier AddGlacierR GET POST
 /config/repository/add/cloud/box.com AddBoxComR GET POST
+/config/repository/add/cloud/gitlab.com AddGitLabR GET POST
 
 /config/repository/pair/local/start StartLocalPairR GET POST
 /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET

templates/configurators/addrepository/cloud.hamlet

@@ -1,16 +1,23 @@
+<h3>
+  <a href="@{AddGitLabR}">
+    <span .glyphicon .glyphicon-plus-sign>
+    \ Gitlab.com
+<p>
+  Hosts git-annex repositories for free.
+
 <h3>
   <a href="@{AddBoxComR}">
     <span .glyphicon .glyphicon-plus-sign>
     \ Box.com
 <p>
-  Provides free cloud storage for small amounts of data.
+  Provides free storage for small amounts of data.
 
 <h3>
   <a href="@{AddRsyncNetR}">
     <span .glyphicon .glyphicon-plus-sign>
     \ Rsync.net
 <p>
-  Works very well with git-annex.
+  Works very well with git-annex for data storage.
   <br>
   Offers a discounted rate for git-annex users.
 

templates/configurators/gitlab.com/add.hamlet

@@ -0,0 +1,47 @@
+<div .col-sm-9>
+  <div .content-box>
+    <h2>
+      Adding a GitLab.com repository
+    <p>
+      <a href="http://gitlab.com/">
+        GitLab.com #
+      provides free public and private git repositories, and supports #
+      git-annex.
+    <p>
+      $case status
+        $of UnusableServer msg
+          <div .alert .alert-danger>
+            <span .glyphicon .glyphicon-warning-sign>
+            \ #{msg}
+        $of ServerNeedsPubKey pubkey
+          <div .alert>
+            <span .glyphicon .glyphicon-warning-sign>
+            \ You need to configure GitLab to accept a SSH public key.
+            <p>
+              Open a tab to #
+                <a href="https://gitlab.com/profile/keys/new">
+                  https://gitlab.com/profile/keys/new
+              and copy and paste this public key into it:
+              <pre>
+                #{pubkey}
+            <p>
+              Once you have added the key to GitLab, come back to this page #
+              to finish setting up the repository.
+        $of _
+          <p>
+            You can sign up for an account on #
+            <a href="http://gitlab.com/">
+              GitLab.com #
+            and create a git repository that you want to use with git-annex, #
+            or find an existing git-annex repository to share with.
+          <p>
+           Copy the GitLab repository's SSH clone url into the form below.
+      <form method="post" .form-horizontal enctype=#{enctype}>
+        <fieldset>
+          ^{form}
+          ^{webAppFormAuthToken}
+          <div .form-group>
+            <div .col-sm-10 .col-sm-offset-2>
+              <button .btn .btn-primary type=submit onclick="$('#setupmodal').modal('show');">
+                Use this gitlab.com repository
+^{sshTestModal}