diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 75a266fa25..e847edd39d 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 88afec7138..80fb5c19a9 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/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 1a4258178a..7d78704cc7 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex assistant webapp configurator for ssh-based remotes - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2015 Joey Hess - - 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,23 @@ 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 = do + {- To ensure the repository is initialized, try to push the + - git-annex branch to it. Then git-annex-shell will see + - the branch and auto-initialize. -} + when needsinit $ do + void $ liftAnnex $ inRepo $ Git.Command.runBool + [ Param "push" + , Param (genSshUrl sshdata) + , Param (fromRef Annex.Branch.name) + ] + 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 +646,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 +671,89 @@ 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 -> + checkor sshdata $ do + (sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata + checkor sshdata' $ + return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID) + where + checkor sshdata ora = 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) + , ora + ) + 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") diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 589919561b..8d8d5c9326 100644 --- a/Assistant/WebApp/routes +++ b/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 diff --git a/debian/changelog b/debian/changelog index c7debba535..2c3b509e54 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 0000000000..e04a8068d5 --- /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 0000000000..06ea255d0c --- /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 33c5c7188f..65c14b7364 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]] diff --git a/templates/configurators/addrepository/cloud.hamlet b/templates/configurators/addrepository/cloud.hamlet index 382ecbbc27..db1dc6fd7e 100644 --- a/templates/configurators/addrepository/cloud.hamlet +++ b/templates/configurators/addrepository/cloud.hamlet @@ -1,16 +1,23 @@ +

+ + + \ Gitlab.com +

+ Hosts git-annex repositories for free. +

\ Box.com

- Provides free cloud storage for small amounts of data. + Provides free storage for small amounts of data.

\ Rsync.net

- Works very well with git-annex. + Works very well with git-annex for data storage.
Offers a discounted rate for git-annex users. diff --git a/templates/configurators/gitlab.com/add.hamlet b/templates/configurators/gitlab.com/add.hamlet new file mode 100644 index 0000000000..407dc0ae32 --- /dev/null +++ b/templates/configurators/gitlab.com/add.hamlet @@ -0,0 +1,47 @@ +

+
+

+ Adding a GitLab.com repository +

+ + GitLab.com # + provides free public and private git repositories, and supports # + git-annex. +

+ $case status + $of UnusableServer msg +

+ + \ #{msg} + $of ServerNeedsPubKey pubkey +
+ + \ You need to configure GitLab to accept a SSH public key. +

+ Open a tab to # + + https://gitlab.com/profile/keys/new + and copy and paste this public key into it: + 

+                #{pubkey}
+            

+              Once you have added the key to GitLab, come back to this page #
+              to finish setting up the repository.
+        $of _
+          

+            You can sign up for an account on #
+            
+              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.
+          

+           Copy the GitLab repository's SSH clone url into the form below.
+      

+        

+          ^{form}
+          ^{webAppFormAuthToken}
+          

+            

+