diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 2619039c0e..1880d519e3 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -9,7 +9,6 @@ module Assistant.MakeRemote where import Assistant.Common import Assistant.Ssh -import Assistant.Sync import qualified Types.Remote as R import qualified Remote import Remote.List @@ -21,8 +20,6 @@ import qualified Command.InitRemote import Logs.UUID import Logs.Remote import Git.Remote -import Config -import Config.Cost import Creds import Assistant.Gpg import Utility.Gpg (KeyId) @@ -30,17 +27,12 @@ import Utility.Gpg (KeyId) import qualified Data.Text as T import qualified Data.Map as M -{- Sets up and begins syncing with a new ssh or rsync remote. -} -makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote -makeSshRemote forcersync sshdata mcost = do - r <- liftAnnex $ - addRemote $ maker (sshRepoName sshdata) - (sshUrl forcersync sshdata) - liftAnnex $ maybe noop (setRemoteCost r) mcost - syncRemote r - return r +{- Sets up a new ssh or rsync remote. -} +makeSshRemote :: Bool -> SshData -> Annex RemoteName +makeSshRemote forcersync sshdata = + maker (sshRepoName sshdata) (sshUrl forcersync sshdata) where - rsync = forcersync || rsyncOnly sshdata + rsync = forcersync || sshCapabilities sshdata == [RsyncCapable] maker | rsync = makeRsyncRemote | otherwise = makeGitRemote @@ -48,7 +40,7 @@ makeSshRemote forcersync sshdata mcost = do {- Generates a ssh or rsync url from a SshData. -} sshUrl :: Bool -> SshData -> String sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $ - if (forcersync || rsyncOnly sshdata) + if (forcersync || sshCapabilities sshdata == [RsyncCapable]) then [u, h, T.pack ":", sshDirectory sshdata] else [T.pack "ssh://", u, h, d] where @@ -146,7 +138,6 @@ makeRemote basename location a = do g <- gitRepo if not (any samelocation $ Git.remotes g) then do - let name = uniqueRemoteName basename 0 g a name return name diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index edd27e35a2..47811963b1 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -12,7 +12,9 @@ import Assistant.Ssh import Assistant.Pairing import Assistant.Pairing.Network import Assistant.MakeRemote +import Assistant.Sync import Config.Cost +import Config import Network.Socket import qualified Data.Text as T @@ -43,7 +45,9 @@ finishedLocalPairing msg keypair = do , "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) ] Nothing - void $ makeSshRemote False sshdata (Just semiExpensiveRemoteCost) + r <- liftAnnex $ addRemote $ makeSshRemote False sshdata + liftAnnex $ setRemoteCost r semiExpensiveRemoteCost + syncRemote r {- Mostly a straightforward conversion. Except: - * Determine the best hostname to use to contact the host. @@ -63,7 +67,7 @@ pairMsgToSshData msg = do , sshRepoName = genSshRepoName hostname dir , sshPort = 22 , needsPubKey = True - , rsyncOnly = False + , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] } {- Finds the best hostname to use for the host that sent the PairMsg. diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index a623190964..9df9b64b9b 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -25,10 +25,16 @@ data SshData = SshData , sshRepoName :: String , sshPort :: Int , needsPubKey :: Bool - , rsyncOnly :: Bool + , sshCapabilities :: [SshServerCapability] } deriving (Read, Show, Eq) +data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable + deriving (Read, Show, Eq) + +hasCapability :: SshData -> SshServerCapability -> Bool +hasCapability d c = c `elem` sshCapabilities d + data SshKeyPair = SshKeyPair { sshPubKey :: String , sshPrivKey :: String diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index f38b3e009d..3f82ba3754 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -205,7 +205,8 @@ enableAWSRemote _ _ = error "S3 not supported by this build" makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler () makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk) - setupCloudRemote defaultgroup $ maker hostname remotetype config + setupCloudRemote defaultgroup Nothing $ + maker hostname remotetype config where {- AWS services use the remote name as the basis for a host - name, so filter it to contain valid characters. -} diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 5ac24ab6e8..7f516376c4 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -17,7 +17,6 @@ import Assistant.MakeRemote import Utility.Rsync (rsyncUrlIsShell) import Logs.Remote import Remote -import Logs.PreferredContent import Types.StandardGroups import Utility.UserInfo import Utility.Gpg @@ -54,7 +53,7 @@ mkSshData s = SshData (maybe "" T.unpack $ inputDirectory s) , sshPort = inputPort s , needsPubKey = False - , rsyncOnly = False + , sshCapabilities = [] -- untested } mkSshInput :: SshData -> SshInput @@ -103,15 +102,12 @@ sshInputAForm hostnamefield def = SshInput data ServerStatus = UntestedServer | UnusableServer Text -- reason why it's not usable - | UsableRsyncServer - | UsableSshInput + | UsableServer [SshServerCapability] deriving (Eq) -usable :: ServerStatus -> Bool -usable UntestedServer = False -usable (UnusableServer _) = False -usable UsableRsyncServer = True -usable UsableSshInput = True +capabilities :: ServerStatus -> [SshServerCapability] +capabilities (UsableServer cs) = cs +capabilities _ = [] getAddSshR :: Handler Html getAddSshR = postAddSshR @@ -143,7 +139,7 @@ postEnableRsyncR :: UUID -> Handler Html postEnableRsyncR = enableSpecialSshRemote "rsyncurl" enableRsyncNet enablersync where enablersync sshdata = redirect $ ConfirmSshR $ - sshdata { rsyncOnly = True } + sshdata { sshCapabilities = [RsyncCapable] } {- This only handles gcrypt repositories that are located on ssh servers; - ones on local drives are handled via another part of the UI. -} @@ -214,8 +210,9 @@ parseSshRsyncUrl u - passwordless login is already enabled, use it. Otherwise, - a special ssh key will need to be generated just for this server. - - - Once logged into the server, probe to see if git-annex-shell is - - available, or rsync. Note that, ~/.ssh/git-annex-shell may be + - Once logged into the server, probe to see if git-annex-shell, + - git, and rsync are available. + - Note that, ~/.ssh/git-annex-shell may be - present, while git-annex-shell is not in PATH. -} testServer :: SshInput -> IO (Either ServerStatus SshData) @@ -223,22 +220,23 @@ testServer (SshInput { inputHostname = Nothing }) = return $ Left $ UnusableServer "Please enter a host name." testServer sshinput@(SshInput { inputHostname = Just hn }) = do status <- probe [sshOpt "NumberOfPasswordPrompts" "0"] - if usable status - then ret status False - else do + case capabilities status of + [] -> do status' <- probe [] - if usable status' - then ret status' True - else return $ Left status' + case capabilities status' of + [] -> return $ Left status' + cs -> ret cs True + cs -> ret cs False where - ret status needspubkey = return $ Right $ (mkSshData sshinput) + ret cs needspubkey = return $ Right $ (mkSshData sshinput) { needsPubKey = needspubkey - , rsyncOnly = status == UsableRsyncServer + , sshCapabilities = cs } probe extraopts = do let remotecommand = shellWrap $ intercalate ";" [ report "loggedin" , checkcommand "git-annex-shell" + , checkcommand "git" , checkcommand "rsync" , checkcommand shim ] @@ -256,14 +254,19 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do , remotecommand ] parsetranscript . fst <$> sshTranscript sshopts Nothing - parsetranscript s - | reported "git-annex-shell" = UsableSshInput - | reported shim = UsableSshInput - | reported "rsync" = UsableRsyncServer - | reported "loggedin" = UnusableServer - "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?" - | otherwise = UnusableServer $ T.pack $ - "Failed to ssh to the server. Transcript: " ++ s + parsetranscript s = + let cs = map snd $ filter (reported . fst) + [ ("git-annex-shell", GitAnnexShellCapable) + , (shim, GitAnnexShellCapable) + , ("git", GitCapable) + , ("rsync", RsyncCapable) + ] + in if null cs + then if reported "loggedin" + then UnusableServer "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?" + else UnusableServer $ T.pack $ + "Failed to ssh to the server. Transcript: " ++ s + else UsableServer cs where reported r = token r `isInfixOf` s @@ -286,7 +289,9 @@ showSshErr msg = sshConfigurator $ $(widgetFile "configurators/ssh/error") getConfirmSshR :: SshData -> Handler Html -getConfirmSshR sshdata = sshConfigurator $ +getConfirmSshR sshdata = sshConfigurator $ do + secretkeys <- sortBy (comparing snd) . M.toList + <$> liftIO secretKeys $(widgetFile "configurators/ssh/confirm") getRetrySshR :: SshData -> Handler () @@ -300,6 +305,9 @@ getMakeSshGitR = makeSsh False getMakeSshRsyncR :: SshData -> Handler Html getMakeSshRsyncR = makeSsh True +getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html +getMakeSshGCryptR sshdata repokey = error "TODO" + makeSsh :: Bool -> SshData -> Handler Html makeSsh rsync sshdata | needsPubKey sshdata = do @@ -312,27 +320,25 @@ makeSsh rsync sshdata | otherwise = makeSsh' rsync sshdata sshdata Nothing makeSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html -makeSsh' rsync origsshdata sshdata keypair = do +makeSsh' rsynconly origsshdata sshdata keypair = do sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $ - makeSshRepo rsync sshdata + makeSshRepo rsynconly sshdata where sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata) remotedir = T.unpack $ sshDirectory sshdata remoteCommand = shellWrap $ intercalate "&&" $ catMaybes [ Just $ "mkdir -p " ++ shellEscape remotedir , Just $ "cd " ++ shellEscape remotedir - , if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi" - , if rsync then Nothing else Just "git annex init" + , if rsynconly then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi" + , if rsynconly then Nothing else Just "git annex init" , if needsPubKey sshdata - then addAuthorizedKeysCommand (rsync || rsyncOnly sshdata) remotedir . sshPubKey <$> keypair + then addAuthorizedKeysCommand rsynconly remotedir . sshPubKey <$> keypair else Nothing ] makeSshRepo :: Bool -> SshData -> Handler Html -makeSshRepo forcersync sshdata = do - r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing - liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup - redirect $ EditNewCloudRepositoryR $ Remote.uuid r +makeSshRepo forcersync sshdata = setupCloudRemote TransferGroup Nothing $ + makeSshRemote forcersync sshdata getAddRsyncNetR :: Handler Html getAddRsyncNetR = postAddRsyncNetR @@ -394,7 +400,7 @@ getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $ withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do sshSetup [sshhost, gitinit] [] $ - setupCloudRemote TransferGroup $ + setupCloudRemote TransferGroup Nothing $ makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid where sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) @@ -413,7 +419,7 @@ enableRsyncNetGCrypt sshinput reponame = notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository." enableRsyncNetGCrypt' :: SshData -> RemoteName -> Handler Html enableRsyncNetGCrypt' sshdata reponame = - setupCloudRemote TransferGroup $ + setupCloudRemote TransferGroup Nothing $ enableSpecialRemote reponame GCrypt.remote $ M.fromList [("gitrepo", sshUrl True sshdata)] @@ -427,7 +433,7 @@ prepRsyncNet sshinput reponame a = do (mkSshData sshinput) { sshRepoName = reponame , needsPubKey = True - , rsyncOnly = True + , sshCapabilities = [RsyncCapable] } {- I'd prefer to separate commands with && , but - rsync.net's shell does not support that. diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 67701768ce..062e257ce9 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -126,7 +126,8 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build" makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler () makeWebDavRemote maker name creds config = do liftIO $ WebDAV.setCredsEnv creds - setupCloudRemote TransferGroup $ maker name WebDAV.remote config + setupCloudRemote TransferGroup Nothing $ + maker name WebDAV.remote config {- Only returns creds previously used for the same hostname. -} previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair) diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index d922de8bd9..5b5ff2cdfb 100644 --- a/Assistant/WebApp/Utility.hs +++ b/Assistant/WebApp/Utility.hs @@ -20,6 +20,7 @@ import qualified Remote.List as Remote import qualified Assistant.Threads.Transferrer as Transferrer import Logs.Transfer import qualified Config +import Config.Cost import Config.Files import Git.Config import Assistant.Threads.Watcher @@ -125,12 +126,13 @@ getCurrentTransfers :: Handler TransferMap getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus {- Runs an action that creates or enables a cloud remote, - - and finishes setting it up; adding it to a group if it's not already in - - one, starts syncing with it, and finishes by displaying the page to edit - - it. -} -setupCloudRemote :: StandardGroup -> Annex RemoteName -> Handler a -setupCloudRemote defaultgroup maker = do + - and finishes setting it up, then starts syncing with it, + - and finishes by displaying the page to edit it. -} +setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a +setupCloudRemote defaultgroup mcost maker = do r <- liftAnnex $ addRemote maker - liftAnnex $ setStandardGroup (Remote.uuid r) defaultgroup + liftAnnex $ do + setStandardGroup (Remote.uuid r) defaultgroup + maybe noop (Config.setRemoteCost r) mcost liftAssistant $ syncRemote r redirect $ EditNewCloudRepositoryR $ Remote.uuid r diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 813c10b2d8..552dcd5daa 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -44,6 +44,7 @@ /config/repository/add/ssh/retry/#SshData RetrySshR GET /config/repository/add/ssh/make/git/#SshData MakeSshGitR GET /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET +/config/repository/add/ssh/make/gcrypt/#SshData/#RepoKey MakeSshGCryptR GET /config/repository/add/cloud/rsync.net AddRsyncNetR GET POST /config/repository/add/cloud/rsync.net/shared/#SshData MakeRsyncNetSharedR GET /config/repository/add/cloud/rsync.net/gcrypt/#SshData/#RepoKey MakeRsyncNetGCryptR GET diff --git a/templates/configurators/rsync.net/encrypt.hamlet b/templates/configurators/rsync.net/encrypt.hamlet index 62811b30ad..af256eee4c 100644 --- a/templates/configurators/rsync.net/encrypt.hamlet +++ b/templates/configurators/rsync.net/encrypt.hamlet @@ -26,11 +26,11 @@

$forall (keyid, name) <- secretkeys

- + Encrypt repository # to ^{gpgKeyDisplay keyid (Just name)}

- + Encrypt repository # with a new encryption key ^{genKeyModal} diff --git a/templates/configurators/ssh/confirm.hamlet b/templates/configurators/ssh/confirm.hamlet index f880589817..e708271a2e 100644 --- a/templates/configurators/ssh/confirm.hamlet +++ b/templates/configurators/ssh/confirm.hamlet @@ -3,45 +3,69 @@ Ready to add remote server

-

- The server #{sshHostName sshdata} has been verified to be usable. -

- You have two options for how to use the server: -

- $if not (rsyncOnly sshdata) - - Use a git repository on the server - $else - - Use a git repository on the server (not available) # - - Retry -
+ $if not (hasCapability sshdata GitAnnexShellCapable) +

# - - The server needs git and git-annex installed to use this option. -
- All your data will be uploaded to the server, including the full # - git repository. This is a great choice if you want to set up # - other devices to use the same server, or share the repository with # - others. -

- -or- + The server #{sshHostName sshdata} can be used as is, but # + installing # + $if not (hasCapability sshdata GitCapable) + git and git-annex # + $else + git-annex # + on it would make it work better, and provide more options below. # +

+ If you're able to install software on the server, do so and click + + Retry + $else +

+ The server #{sshHostName sshdata} has been verified to be usable. # + Depending on whether you trust this server, you can choose between # + storing your data on it encrypted, or unencrypted. +

+ Unencrypted repository +

+ All your data will be uploaded to the server, including a clone of # + the git repository. This is a good choice if you want to set up # + other devices to use the same server, or share the repository with # + others. +

+ + Make an unencrypted git repository on the server +

+ -or- +

+ Simple shared encryption

- - Use an encrypted rsync repository on the server -
- The contents of your files will be stored, fully encrypted, on the # - server. The server will not store other information about your # - git repository. This is the best choice if you don't run the server # - yourself, or have sensitive data. -

- $if needsPubKey sshdata -
- # - A ssh key will be installed on the server, allowing git-annex to # - access it securely without a password. + This allows everyone who has a clone of this repository to # + decrypt the files stored on #{sshHostName sshdata}. That makes # + it good for sharing. And it's easy to set up and use. +

+ + Use shared encryption + $if hasCapability sshdata GitCapable +

+ -or- +

+ Encrypt with GnuPG key +

+ This stores an encrypted clone of your repository on # + #{sshHostName sshdata}, unlike shared encryption which only # + stores file contents there. So it's good for backups. But the # + encryption will prevent you from sharing the repository with # + friends, or easily accessing its contents on another computer. +

+ $forall (keyid, name) <- secretkeys +

+ + Encrypt repository # + to ^{gpgKeyDisplay keyid (Just name)} +

+ + Encrypt repository # + with a new encryption key ^{sshTestModal} +^{genKeyModal}