diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 87129757ef..b5dcbfcf9d 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -213,23 +213,21 @@ enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> enableSshRemote getsshdata rsyncnetsetup genericsetup u = do m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog 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 + (Just sshdata, Just reponame) -> 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 @@ -675,110 +673,3 @@ 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 { unGitLabUrl :: 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) - } - -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. - - - - 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 NoConsumeStdin 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 :: 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 - -getAddGitLabR :: Handler Html -getAddGitLabR = postAddGitLabR -postAddGitLabR :: Handler Html -postAddGitLabR = promptGitLab Nothing - -promptGitLab :: Maybe GitLabUrl -> Handler Html -promptGitLab defval = sshConfigurator $ do - ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ - gitLabUrlAForm defval - 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") - -enableGitLab :: SshData -> Handler Html -enableGitLab = promptGitLab . Just . toGitLabUrl diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 4a8da2067d..e393d02b97 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -30,9 +30,6 @@ import Network.URI webDAVConfigurator :: Widget -> Handler Html webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) -boxConfigurator :: Widget -> Handler Html -boxConfigurator = page "Add a Box.com repository" (Just Configuration) - data WebDAVInput = WebDAVInput { user :: Text , password :: Text @@ -44,14 +41,6 @@ data WebDAVInput = WebDAVInput toCredPair :: WebDAVInput -> CredPair toCredPair input = (T.unpack $ user input, T.unpack $ password input) -boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput -boxComAForm defcreds = WebDAVInput - <$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds) - <*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds) - <*> areq checkBoxField "Share this account with other devices and friends?" (Just True) - <*> areq textField (bfs "Directory") (Just "annex") - <*> enableEncryptionField - webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput webDAVCredsAForm defcreds = WebDAVInput <$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds) @@ -60,32 +49,6 @@ webDAVCredsAForm defcreds = WebDAVInput <*> pure T.empty <*> pure NoEncryption -- not used! -getAddBoxComR :: Handler Html -getAddBoxComR = postAddBoxComR -postAddBoxComR :: Handler Html -#ifdef WITH_WEBDAV -postAddBoxComR = boxConfigurator $ do - defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com" - ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout - $ boxComAForm defcreds - case result of - FormSuccess input -> liftH $ - makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList - [ configureEncryption $ enableEncryption input - , ("embedcreds", if embedCreds input then "yes" else "no") - , ("type", "webdav") - , ("url", "https://dav.box.com/dav/" ++ T.unpack (directory input)) - -- Box.com has a max file size of 100 mb, but - -- using smaller chunks has better memory - -- performance. - , ("chunk", "10mb") - ] - _ -> $(widgetFile "configurators/addbox.com") -#else -postAddBoxComR = giveup "WebDAV not supported by this build" -#endif - getEnableWebDAVR :: UUID -> Handler Html getEnableWebDAVR = postEnableWebDAVR postEnableWebDAVR :: UUID -> Handler Html @@ -101,11 +64,7 @@ postEnableWebDAVR uuid = do case mcreds of Just creds -> webDAVConfigurator $ liftH $ makeWebDavRemote enableSpecialRemote name creds M.empty - Nothing - | "box.com/" `isInfixOf` url -> - boxConfigurator $ showform name url - | otherwise -> - webDAVConfigurator $ showform name url + Nothing -> webDAVConfigurator $ showform name url where showform name url = do defcreds <- liftAnnex $ diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 9be10ba940..8774228081 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -55,8 +55,6 @@ /config/repository/add/cloud/S3 AddS3R GET POST /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/CHANGELOG b/CHANGELOG index 719cde42bb..44104a1381 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -39,6 +39,10 @@ git-annex (7.20181212) UNRELEASED; urgency=medium * Windows: If 64 bit git is installed, use it when installing git-annex. (However, rsync still won't work and this is still not the documented way to install it.) + * webapp: Remove configurator for box.com repository, since their + webdav support is going away at the end of this January. + * webapp: Remove configurator for gitlab, which stopped supporting git-annex + some time ago. -- Joey Hess Tue, 18 Dec 2018 12:24:52 -0400 diff --git a/git-annex.cabal b/git-annex.cabal index ff2db6e39c..89f9525c12 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -209,7 +209,6 @@ Extra-Source-Files: templates/configurators/edit/webrepository.hamlet templates/configurators/edit/repository.hamlet templates/configurators/unused.hamlet - templates/configurators/addbox.com.hamlet templates/configurators/ssh/testmodal.hamlet templates/configurators/ssh/expiredpassword.hamlet templates/configurators/ssh/error.hamlet @@ -228,7 +227,6 @@ Extra-Source-Files: templates/configurators/addrepository/wormholepairing.hamlet templates/configurators/rsync.net/add.hamlet templates/configurators/rsync.net/encrypt.hamlet - templates/configurators/gitlab.com/add.hamlet templates/configurators/needgcrypt.hamlet templates/configurators/needtor.hamlet templates/configurators/needmagicwormhole.hamlet diff --git a/templates/configurators/addbox.com.hamlet b/templates/configurators/addbox.com.hamlet deleted file mode 100644 index 99b0221ee3..0000000000 --- a/templates/configurators/addbox.com.hamlet +++ /dev/null @@ -1,28 +0,0 @@ -
-
-

- Adding a Box.com repository -

- Box.com offers a small quantity of storage # - for free, and larger quantities for a fee. -

- Even a small amount of free storage is useful, as a transfer point # - between your repositories. -

-

-
- ^{form} - ^{webAppFormAuthToken} -
-
-