diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 7d78704cc7..96a99fad7f 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -212,23 +212,26 @@ postEnableSshGitRemoteR = enableSshRemote getsshinput enableRsyncNet enablesshgi - to prompt for its password. -} enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html -enableSshRemote getsshinput rsyncnetsetup genericsetup u = do +enableSshRemote getsshdata rsyncnetsetup genericsetup u = do m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog - case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of - (Just sshinput, Just reponame) -> sshConfigurator $ do - ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField sshinput - case result of - FormSuccess sshinput' - | isRsyncNet (inputHostname sshinput') -> - void $ liftH $ rsyncnetsetup sshinput' reponame - | otherwise -> do - s <- liftAssistant $ testServer sshinput' - case s of - Left status -> showform form enctype status - Right (sshdata, _u) -> void $ liftH $ genericsetup - ( sshdata { sshRepoName = reponame } ) u - _ -> showform form enctype UntestedServer + case (unmangle <$> getsshdata m, M.lookup "name" m) of + (Just sshdata, Just reponame) + | isGitLab sshdata -> enableGitLab sshdata + | otherwise -> sshConfigurator $ do + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ + sshInputAForm textField $ mkSshInput sshdata + case result of + FormSuccess sshinput + | isRsyncNet (inputHostname sshinput) -> + void $ liftH $ rsyncnetsetup sshinput reponame + | otherwise -> do + s <- liftAssistant $ testServer sshinput + case s of + Left status -> showform form enctype status + Right (sshdata', _u) -> void $ liftH $ genericsetup + ( sshdata' { sshRepoName = reponame } ) u + _ -> showform form enctype UntestedServer _ -> redirect AddSshR where unmangle sshdata = sshdata @@ -672,7 +675,7 @@ isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host -data GitLabUrl = GitLabUrl Text +data GitLabUrl = GitLabUrl { unGitLabUrl :: Text } badGitLabUrl :: Text badGitLabUrl = "Bad SSH clone url. Expected something like: git@gitlab.com:yourlogin/annex.git" @@ -698,6 +701,18 @@ parseGitLabUrl (GitLabUrl t) = , sshRepoUrl = Just (T.unpack t) } +isGitLab :: SshData -> Bool +isGitLab d = T.pack "gitlab.com" `T.isSuffixOf` (T.toLower (sshHostName d)) + +toGitLabUrl :: SshData -> GitLabUrl +toGitLabUrl d = GitLabUrl $ T.concat + [ fromMaybe (T.pack "git") (sshUserName d) + , T.pack "@" + , sshHostName d + , T.pack ":" + , sshDirectory d + ] + {- 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. - @@ -735,8 +750,8 @@ testGitLabUrl glu = case parseGitLabUrl glu of , Param (fromRef Annex.Branch.name) ] -gitLabUrlAForm :: AForm Handler GitLabUrl -gitLabUrlAForm = GitLabUrl <$> areq check_input (bfs "SSH clone url") Nothing +gitLabUrlAForm :: Maybe GitLabUrl -> AForm Handler GitLabUrl +gitLabUrlAForm defval = GitLabUrl <$> areq check_input (bfs "SSH clone url") (unGitLabUrl <$> defval) where check_input = checkBool (isJust . parseGitLabUrl . GitLabUrl) badGitLabUrl textField @@ -744,9 +759,13 @@ gitLabUrlAForm = GitLabUrl <$> areq check_input (bfs "SSH clone url") Nothing getAddGitLabR :: Handler Html getAddGitLabR = postAddGitLabR postAddGitLabR :: Handler Html -postAddGitLabR = sshConfigurator $ do +postAddGitLabR = promptGitLab Nothing + +promptGitLab :: Maybe GitLabUrl -> Handler Html +promptGitLab defval = sshConfigurator $ do ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout gitLabUrlAForm + runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ + gitLabUrlAForm defval case result of FormSuccess gitlaburl -> do (status, msshdata, u) <- liftAnnex $ testGitLabUrl gitlaburl @@ -757,3 +776,6 @@ postAddGitLabR = sshConfigurator $ do _ -> showform form enctype UntestedServer where showform form enctype status = $(widgetFile "configurators/gitlab.com/add") + +enableGitLab :: SshData -> Handler Html +enableGitLab = promptGitLab . Just . toGitLabUrl diff --git a/debian/changelog b/debian/changelog index 4541a68863..7ca0944d63 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-annex (5.20150728) UNRELEASED; urgency=medium + + * webapp: Support enabling known gitlab.com remotes. + + -- Joey Hess Mon, 27 Jul 2015 15:57:07 -0400 + git-annex (5.20150727) unstable; urgency=medium * Fix bug that prevented uploads to remotes using new-style chunking diff --git a/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn b/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn index e04a8068d5..35ebc40a0d 100644 --- a/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn +++ b/doc/bugs/enabling_existing_gitlab_repo_in_webapp_broken.mdwn @@ -4,3 +4,5 @@ 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]] + +> [[fixed|done]] --[[Joey]]