webapp: remove configurators for obsolste cloud storage services
* 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. This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess
parent
e0b3ba3819
commit
9a4406e5e7
8 changed files with 20 additions and 262 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue