diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 8a93e359bd..2619039c0e 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -47,10 +47,10 @@ makeSshRemote forcersync sshdata mcost = do {- Generates a ssh or rsync url from a SshData. -} sshUrl :: Bool -> SshData -> String -sshUrl forcersync sshdata = T.unpack $ T.concat $ +sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $ if (forcersync || rsyncOnly sshdata) - then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"] - else [T.pack "ssh://", u, h, d, T.pack "/"] + 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 @@ -58,7 +58,10 @@ sshUrl forcersync sshdata = T.unpack $ T.concat $ | T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata | T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata] | otherwise = T.concat [T.pack "/~/", sshDirectory sshdata] - + addtrailingslash s + | "/" `isSuffixOf` s = s + | otherwise = s ++ "/" + {- Runs an action that returns a name of the remote, and finishes adding it. -} addRemote :: Annex RemoteName -> Annex Remote addRemote a = do diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 3698c58e48..d11d1a44ab 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -22,6 +22,10 @@ import Types.StandardGroups import Utility.UserInfo import Utility.Gpg import Assistant.Sync +import qualified Remote.GCrypt as GCrypt +import qualified Git.GCrypt +import Types.Remote (RemoteConfigKey) +import Git.Remote import qualified Data.Text as T import qualified Data.Map as M @@ -131,39 +135,48 @@ postAddSshR = sshConfigurator $ do sshTestModal :: Widget sshTestModal = $(widgetFile "configurators/ssh/testmodal") -{- This only handles gcrypt repositories that are located on ssh servers; - - ones on local drives are handled via another part of the UI. -} -getEnableGCryptR :: UUID -> Handler Html -getEnableGCryptR = postEnableGCryptR -postEnableGCryptR :: UUID -> Handler Html -postEnableGCryptR u = error "TODO" - -{- To enable an existing rsync special remote, parse the SshInput from - - its rsyncurl, and display a form whose only real purpose is to check - - if ssh public keys need to be set up. From there, we can proceed with - - the usual repo setup; all that code is idempotent. - - - - Note that there's no EnableSshR because ssh remotes are not special +{- Note that there's no EnableSshR because ssh remotes are not special - remotes, and so their configuration is not shared between repositories. -} getEnableRsyncR :: UUID -> Handler Html getEnableRsyncR = postEnableRsyncR postEnableRsyncR :: UUID -> Handler Html -postEnableRsyncR u = do +postEnableRsyncR = enableSpecialSshRemote "rsyncurl" enableRsyncNet enablersync + where + enablersync sshdata = redirect $ ConfirmSshR $ + sshdata { rsyncOnly = True } + +{- This only handles gcrypt repositories that are located on ssh servers; + - ones on local drives are handled via another part of the UI. -} +getEnableGCryptR :: UUID -> Handler Html +getEnableGCryptR = postEnableGCryptR +postEnableGCryptR :: UUID -> Handler Html +postEnableGCryptR u = whenGcryptInstalled $ + enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablersync u + where + enablersync sshdata = error "TODO enable ssh gcrypt remote" + +{- To enable an special remote that uses ssh as its transport, + - parse a config key to get its url, and display a form whose + - only real purpose is to check if ssh public keys need to be + - set up. + -} +enableSpecialSshRemote :: RemoteConfigKey -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> Handler ()) -> UUID -> Handler Html +enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog - case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of + case (parseSshRsyncUrl =<< M.lookup urlkey m, M.lookup "name" m) of (Just sshinput, Just reponame) -> sshConfigurator $ do ((result, form), enctype) <- liftH $ runFormPost $ renderBootstrap $ sshInputAForm textField sshinput case result of FormSuccess sshinput' | isRsyncNet (inputHostname sshinput') -> - void $ liftH $ enableRsyncNet sshinput' reponame (const noop) + void $ liftH $ rsyncnetsetup sshinput' reponame | otherwise -> do s <- liftIO $ testServer sshinput' case s of Left status -> showform form enctype status - Right sshdata -> enable sshdata + Right sshdata -> liftH $ genericsetup sshdata { sshRepoName = reponame } _ -> showform form enctype UntestedServer _ -> redirect AddSshR @@ -171,8 +184,6 @@ postEnableRsyncR u = do showform form enctype status = do description <- liftAnnex $ T.pack <$> prettyUUID u $(widgetFile "configurators/ssh/enable") - enable sshdata = liftH $ redirect $ ConfirmSshR $ - sshdata { rsyncOnly = True } {- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync - url; rsync:// urls or bare path names are not supported. @@ -377,10 +388,28 @@ getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata) -enableRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html -enableRsyncNet sshinput reponame setup = +enableRsyncNet :: SshInput -> String -> Handler Html +enableRsyncNet sshinput reponame = prepRsyncNet sshinput reponame $ \sshdata -> - makeSshRepo True setup sshdata + makeSshRepo True (const noop) sshdata + +enableRsyncNetGCrypt :: SshInput -> String -> Handler Html +enableRsyncNetGCrypt sshinput reponame = + prepRsyncNet sshinput reponame $ \sshdata -> do + let repourl = sshUrl True sshdata + pr <- liftAnnex $ inRepo $ Git.GCrypt.probeRepo repourl + case pr of + Git.GCrypt.Decryptable -> do + r <- liftAnnex $ addRemote $ + enableSpecialRemote reponame GCrypt.remote $ M.fromList + [("gitrepo", repourl)] + setupGroup r + liftAssistant $ syncRemote r + redirect $ EditNewCloudRepositoryR $ Remote.uuid r + Git.GCrypt.NotDecryptable -> + error "The drive contains a git repository that is encrypted with a GnuPG key that you do not have." + Git.GCrypt.NotEncrypted -> + error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository." {- Prepares rsync.net ssh key, and if successful, runs an action with - its SshData. -} diff --git a/Command/List.hs b/Command/List.hs index 56ec0cd034..fda8f3dc7c 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -22,6 +22,7 @@ import Logs.UUID import Annex.UUID import qualified Option import qualified Annex +import Git.Remote def :: [Command] def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek @@ -68,7 +69,6 @@ start l file (key, _) = do liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file stop -type RemoteName = String type Present = Bool header :: [(RemoteName, TrustLevel)] -> String diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index f2f38dfa4f..0da68bf24f 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -15,6 +15,7 @@ import Git.Construct import qualified Git.Config as Config import qualified Git.Command as Command import Utility.Gpg +import Git.Remote urlPrefix :: String urlPrefix = "gcrypt::" @@ -66,7 +67,6 @@ probeRepo loc baserepo = do ExitFailure 1 -> NotDecryptable ExitFailure _ -> NotEncrypted -type RemoteName = String type GCryptId = String {- gcrypt gives each encrypted repository a uique gcrypt-id, diff --git a/Remote.hs b/Remote.hs index 25a46b1cb2..0638e65b06 100644 --- a/Remote.hs +++ b/Remote.hs @@ -56,6 +56,7 @@ import Logs.Trust import Logs.Location hiding (logStatus) import Remote.List import Config +import Git.Remote {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> a) -> Annex (M.Map UUID a) @@ -68,7 +69,7 @@ remoteMap c = M.fromList . map (\r -> (uuid r, c r)) . uuidDescriptions :: Annex (M.Map UUID String) uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name -addName :: String -> String -> String +addName :: String -> RemoteName -> String addName desc n | desc == n = desc | null desc = n @@ -76,12 +77,12 @@ addName desc n {- When a name is specified, looks up the remote matching that name. - (Or it can be a UUID.) -} -byName :: Maybe String -> Annex (Maybe Remote) +byName :: Maybe RemoteName -> Annex (Maybe Remote) byName Nothing = return Nothing byName (Just n) = either error Just <$> byName' n {- Like byName, but the remote must have a configured UUID. -} -byNameWithUUID :: Maybe String -> Annex (Maybe Remote) +byNameWithUUID :: Maybe RemoteName -> Annex (Maybe Remote) byNameWithUUID = checkuuid <=< byName where checkuuid Nothing = return Nothing @@ -93,7 +94,7 @@ byNameWithUUID = checkuuid <=< byName else error e | otherwise = return $ Just r -byName' :: String -> Annex (Either String Remote) +byName' :: RemoteName -> Annex (Either String Remote) byName' "" = return $ Left "no remote specified" byName' n = handle . filter matching <$> remoteList where @@ -104,7 +105,7 @@ byName' n = handle . filter matching <$> remoteList {- Looks up a remote by name (or by UUID, or even by description), - and returns its UUID. Finds even remotes that are not configured in - .git/config. -} -nameToUUID :: String -> Annex UUID +nameToUUID :: RemoteName -> Annex UUID nameToUUID "." = getUUID -- special case for current repo nameToUUID "here" = getUUID nameToUUID "" = error "no remote specified" diff --git a/Types/Remote.hs b/Types/Remote.hs index 78008ce06b..918566e8dd 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -18,6 +18,7 @@ import Types.UUID import Types.GitConfig import Config.Cost import Utility.Metered +import Git.Remote type RemoteConfigKey = String type RemoteConfig = M.Map RemoteConfigKey String @@ -42,7 +43,7 @@ data RemoteA a = Remote { -- each Remote has a unique uuid uuid :: UUID, -- each Remote has a human visible name - name :: String, + name :: RemoteName, -- Remotes have a use cost; higher is more expensive cost :: Cost, -- Transfers a key to the remote. diff --git a/templates/configurators/editrepository.hamlet b/templates/configurators/editrepository.hamlet index 95faa9a78f..94a2702e7a 100644 --- a/templates/configurators/editrepository.hamlet +++ b/templates/configurators/editrepository.hamlet @@ -1,7 +1,7 @@
- Another repository uses this server, but the server is not # - yet enabled for use here. The first step to enable it is to check if it's # - usable here. + To enable this repository, you first need to check that its ssh server # + is usable from here.