UI for making encrypted ssh remotes with gcrypt

Improved probing the remote server, so it gathers a list of the
capabilities it has. From that list, we can determine which types
of remotes are supported, and display an appropriate UI.

The new buttons for making gcrypt repos don't work yet, but the old buttons
for unencrypted git repo and encrypted rsync repo have been adapted to the
new data types and are working.

This commit was sponsored by David Schmitt.

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

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.

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

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. -}

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.

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)

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

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

templates/configurators/rsync.net/encrypt.hamlet

@@ -26,11 +26,11 @@
   <p>
     $forall (keyid, name) <- secretkeys
       <p>
-        <a .btn onclick="$('#setupmodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata (RepoKey keyid)}">
+        <a .btn href="@{MakeRsyncNetGCryptR sshdata (RepoKey keyid)}" onclick="$('#setupmodal').modal('show');">
           <i .icon-lock></i> Encrypt repository #
         to ^{gpgKeyDisplay keyid (Just name)}
   <p>
-    <a .btn onclick="$('#genkeymodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata NoRepoKey}">
+    <a .btn href="@{MakeRsyncNetGCryptR sshdata NoRepoKey}" onclick="$('#genkeymodal').modal('show');">
       <i .icon-plus-sign></i> Encrypt repository #
     with a new encryption key
 ^{genKeyModal}

templates/configurators/ssh/confirm.hamlet

@@ -3,45 +3,69 @@
     Ready to add remote server
   <div .row-fluid>
     <div .span9>
-      <p>
-        The server #{sshHostName sshdata} has been verified to be usable.
-      <p>
-        You have two options for how to use the server:
-      <p>
-        $if not (rsyncOnly sshdata)
-          <a .btn .btn-primary href="@{MakeSshGitR sshdata}" onclick="$('#setupmodal').modal('show');">
-            Use a git repository on the server
-        $else
-          <a .btn .disabled .btn-warning href="@{RetrySshR sshdata}" onclick="$('#testmodal').modal('show');">
-            Use a git repository on the server (not available) #
-          <a .btn .btn-primary href="@{RetrySshR sshdata}" onclick="$('#testmodal').modal('show');">
-            Retry
-          <br>
+      $if not (hasCapability sshdata GitAnnexShellCapable)
+        <p>
           <i .icon-warning-sign></i> #
-          <i>
-            The server needs git and git-annex installed to use this option.
-        <br>
-        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.
-      <p style="text-align: center">
-        -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. #
+        <p>
+          If you're able to install software on the server, do so and click
+          <a .btn href="@{RetrySshR sshdata}" onclick="$('#testmodal').modal('show');">
+            Retry
+      $else
+        <p>
+          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.
+        <h3>
+          Unencrypted repository
+        <p>
+          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.
+        <p>
+          <a .btn href="@{MakeSshGitR sshdata}" onclick="$('#setupmodal').modal('show');">
+            Make an unencrypted git repository on the server
+        <p style="text-align: center">
+          -or-
+      <h3>
+        Simple shared encryption
       <p>
-        <a .btn .btn-primary href="@{MakeSshRsyncR sshdata}" onclick="$('#setupmodal').modal('show');">
-          Use an encrypted rsync repository on the server
-        <br>
-        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.
-    <div .span4>
-      $if needsPubKey sshdata
-        <div .alert .alert-info>
-          <i .icon-info-sign></i> #
-          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.
+      <p>
+        <a .btn href="@{MakeSshRsyncR sshdata}" onclick="$('#setupmodal').modal('show');">
+          <i .icon-lock></i> Use shared encryption
+      $if hasCapability sshdata GitCapable
+        <p style="text-align: center">
+          -or-
+        <h3>
+          Encrypt with GnuPG key
+        <p>
+          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.
+        <p>
+          $forall (keyid, name) <- secretkeys
+            <p>
+              <a .btn href="@{MakeSshGCryptR sshdata (RepoKey keyid)}" onclick="$('#setupmodal').modal('show');" >
+                <i .icon-lock></i> Encrypt repository #
+              to ^{gpgKeyDisplay keyid (Just name)}
+        <p>
+          <a .btn href="@{MakeSshGCryptR sshdata NoRepoKey}" onclick="$('#genkeymodal').modal('show');">
+            <i .icon-plus-sign></i> Encrypt repository #
+          with a new encryption key
 ^{sshTestModal}
+^{genKeyModal}
 <div .modal .fade #setupmodal>
   <div .modal-header>
     <h3>