webapp: Support storing encrypted git repositories on rsync.net.

Does not yet support re-enabling such a repository though.

This commit was sponsored by Jan Pieper.

Assistant/Gpg.hs

@@ -0,0 +1,36 @@
+{- git-annex assistant gpg stuff
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.Gpg where
+
+import Utility.Gpg
+import Utility.UserInfo
+import Types.Remote (RemoteConfigKey)
+
+import qualified Data.Map as M
+
+{- Generates a gpg user id that is not used by any existing secret key -}
+newUserId :: IO UserId
+newUserId = do
+	oldkeys <- secretKeys
+	username <- myUserName
+  	let basekeyname = username ++ "'s git-annex encryption key"
+	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
+		( basekeyname
+		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
+		)
+
+data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
+	deriving (Eq)
+
+{- Generates Remote configuration for encryption. -}
+configureEncryption :: EnableEncryption -> (RemoteConfigKey, String)
+configureEncryption SharedEncryption = ("encryption", "shared")
+configureEncryption NoEncryption = ("encryption", "none")
+configureEncryption HybridEncryption = ("encryption", "hybrid")

Assistant/MakeRemote.hs

@@ -14,6 +14,7 @@ import qualified Types.Remote as R
 import qualified Remote
 import Remote.List
 import qualified Remote.Rsync as Rsync
+import qualified Remote.GCrypt as GCrypt
 import qualified Git
 import qualified Git.Command
 import qualified Command.InitRemote
@@ -23,6 +24,8 @@ import Git.Remote
 import Config
 import Config.Cost
 import Creds
+import Assistant.Gpg
+import Utility.Gpg (KeyId)
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -31,7 +34,8 @@ import qualified Data.Map as M
 makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
 makeSshRemote forcersync sshdata mcost = do
 	r <- liftAnnex $
-		addRemote $ maker (sshRepoName sshdata) sshurl
+		addRemote $ maker (sshRepoName sshdata)
+			(sshUrl forcersync sshdata)
 	liftAnnex $ maybe noop (setRemoteCost r) mcost
 	syncRemote r
 	return r
@@ -40,8 +44,11 @@ makeSshRemote forcersync sshdata mcost = do
 	maker
 		| rsync = makeRsyncRemote
 		| otherwise = makeGitRemote
-	sshurl = T.unpack $ T.concat $
-		if rsync
+
+{- Generates a ssh or rsync url from a SshData. -}
+sshUrl :: Bool -> SshData -> String
+sshUrl forcersync sshdata = 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 "/"]
   where
@@ -74,6 +81,16 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
 		, ("type", "rsync")
 		]
 
+{- Inits a gcrypt special remote, and returns its name. -}
+makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
+makeGCryptRemote remotename location keyid = 
+	initSpecialRemote remotename GCrypt.remote $ M.fromList
+		[ ("type", "gcrypt")
+		, ("gitrepo", location)
+		, configureEncryption HybridEncryption
+		, ("keyid", keyid)
+		]
+
 type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
 
 {- Inits a new special remote. The name is used as a suggestion, but

Assistant/WebApp/Configurators/AWS.hs

@@ -24,6 +24,7 @@ import Types.Remote (RemoteConfig)
 import Types.StandardGroups
 import Logs.PreferredContent
 import Creds
+import Assistant.Gpg
 
 import qualified Data.Text as T
 import qualified Data.Map as M

Assistant/WebApp/Configurators/IA.hs

@@ -24,6 +24,7 @@ import Logs.PreferredContent
 import Logs.Remote
 import qualified Utility.Url as Url
 import Creds
+import Assistant.Gpg
 
 import qualified Data.Text as T
 import qualified Data.Map as M

Assistant/WebApp/Configurators/Local.hs

@@ -276,17 +276,14 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
 setupDriveModal :: Widget
 setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")
 
-genKeyModal :: Widget
-genKeyModal = $(widgetFile "configurators/genkeymodal")
-
 getGenKeyForDriveR :: RemovableDrive -> Handler Html
-getGenKeyForDriveR drive = withNewSecretKey $ \key -> do
+getGenKeyForDriveR drive = withNewSecretKey $ \keyid -> do
 	{- Generating a key takes a long time, and 
 	 - the removable drive may have been disconnected
 	 - in the meantime. Check that it is still mounted
 	 - before finishing. -}
 	ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList)
-		( getFinishAddDriveR drive (RepoKey key)
+		( getFinishAddDriveR drive (RepoKey keyid)
 		, getAddDriveR
 		)
 
@@ -296,12 +293,7 @@ getFinishAddDriveR drive = go
   	{- Set up new gcrypt special remote. -}
 	go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
 		r <- liftAnnex $ addRemote $
-			initSpecialRemote remotename GCrypt.remote $ M.fromList
-				[ ("type", "gcrypt")
-				, ("gitrepo", dir)
-				, configureEncryption HybridEncryption
-				, ("keyid", keyid)
-				]
+			makeGCryptRemote remotename dir keyid
 		return (Types.Remote.uuid r, r)
 	go NoRepoKey = do
 		pr <- liftAnnex $ inRepo $ Git.GCrypt.probeRepo dir

Assistant/WebApp/Configurators/Ssh.hs

@@ -11,6 +11,7 @@
 module Assistant.WebApp.Configurators.Ssh where
 
 import Assistant.WebApp.Common
+import Assistant.WebApp.Gpg
 import Assistant.Ssh
 import Assistant.MakeRemote
 import Utility.Rsync (rsyncUrlIsShell)
@@ -19,10 +20,13 @@ import Remote
 import Logs.PreferredContent
 import Types.StandardGroups
 import Utility.UserInfo
+import Utility.Gpg
+import Assistant.Sync
 
 import qualified Data.Text as T
 import qualified Data.Map as M
 import Network.Socket
+import Data.Ord
 
 sshConfigurator :: Widget -> Handler Html
 sshConfigurator = page "Add a remote server" (Just Configuration)
@@ -147,7 +151,7 @@ postEnableRsyncR u = do
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (inputHostname sshinput') ->
-						void $ liftH $ makeRsyncNet sshinput' reponame (const noop)
+						void $ liftH $ enableRsyncNet sshinput' reponame (const noop)
 					| otherwise -> do
 						s <- liftIO $ testServer sshinput'
 						case s of
@@ -320,19 +324,17 @@ postAddRsyncNetR = do
 	((result, form), enctype) <- runFormPost $
 		renderBootstrap $ sshInputAForm hostnamefield $
 			SshInput Nothing Nothing Nothing 22
-	let showform status = page "Add a Rsync.net repository" (Just Configuration) $
-		$(widgetFile "configurators/addrsync.net")
+	let showform status = inpage $
+		$(widgetFile "configurators/rsync.net/add")
 	case result of
 		FormSuccess sshinput
-			| isRsyncNet (inputHostname sshinput) -> do
-				let reponame = genSshRepoName "rsync.net" 
-					(maybe "" T.unpack $ inputDirectory sshinput)
-				makeRsyncNet sshinput reponame setupGroup
+			| isRsyncNet (inputHostname sshinput) -> prep sshinput
 			| otherwise ->
 				showform $ UnusableServer
 					"That is not a rsync.net host name."
 		_ -> showform UntestedServer
   where
+  	inpage = page "Add a Rsync.net repository" (Just Configuration)
 	hostnamefield = textField `withExpandableNote` ("Help", help)
 	help = [whamlet|
 <div>
@@ -342,9 +344,41 @@ postAddRsyncNetR = do
   The host name will be something like "usw-s001.rsync.net", and the #
   user name something like "7491"
 |]
+	prep sshinput = do
+		let reponame = genSshRepoName "rsync.net" 
+			(maybe "" T.unpack $ inputDirectory sshinput)
+		prepRsyncNet sshinput reponame $ \sshdata -> inpage $ do
+			secretkeys <- sortBy (comparing snd) . M.toList
+				<$> liftIO secretKeys
+			$(widgetFile "configurators/rsync.net/encrypt")					
 
-makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html
-makeRsyncNet sshinput reponame setup = do
+getMakeRsyncNetSharedR :: SshData -> Handler Html
+getMakeRsyncNetSharedR sshdata = makeSshRepo True setupGroup sshdata
+
+{- Make a gcrypt special remote on rsync.net. -}
+getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
+getMakeRsyncNetGCryptR sshdata NoRepoKey = withNewSecretKey $ \keyid -> 
+	getMakeRsyncNetGCryptR sshdata (RepoKey keyid)
+getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = do
+	sshSetup [sshhost, gitinit] [] $ do
+		r <- liftAnnex $ addRemote $
+			makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid
+		setupGroup r
+		liftAssistant $ syncRemote r
+		redirect $ EditNewCloudRepositoryR $ Remote.uuid r
+  where
+	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 = 
+	prepRsyncNet sshinput reponame $ \sshdata ->
+		makeSshRepo True setup sshdata
+
+{- Prepares rsync.net ssh key, and if successful, runs an action with
+ - its SshData. -}
+prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
+prepRsyncNet sshinput reponame a = do
 	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
 	keypair <- liftIO $ genSshKeyPair
 	sshdata <- liftIO $ setupSshKeyPair keypair $
@@ -371,8 +405,7 @@ makeRsyncNet sshinput reponame setup = do
 		, genSshHost (sshHostName sshdata) (sshUserName sshdata)
 		, remotecommand
 		]
-	sshSetup sshopts (sshPubKey keypair) $
-		makeSshRepo True setup sshdata
+	sshSetup sshopts (sshPubKey keypair) $ a sshdata
 
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False

Assistant/WebApp/Configurators/WebDAV.hs

@@ -20,6 +20,7 @@ import Types.Remote (RemoteConfig)
 import Types.StandardGroups
 import Logs.PreferredContent
 import Logs.Remote
+import Assistant.Gpg
 
 import qualified Data.Map as M
 #endif

Assistant/WebApp/Form.hs

@@ -12,8 +12,8 @@
 
 module Assistant.WebApp.Form where
 
-import Types.Remote (RemoteConfigKey)
 import Assistant.WebApp.Types
+import Assistant.Gpg
 
 import Yesod hiding (textField, passwordField)
 import Yesod.Form.Fields as F
@@ -75,9 +75,6 @@ withExpandableNote field (toggle, note) = withNote field $ [whamlet|
   where
   	ident = "toggle_" ++ toggle
 
-data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
-	deriving (Eq)
-
 {- Adds a check box to an AForm to control encryption. -}
 #if MIN_VERSION_yesod(1,2,0)
 enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
@@ -91,9 +88,3 @@ enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just Shared
 		[ ("Encrypt all data", SharedEncryption)
 		, ("Disable encryption", NoEncryption)
 		]
-
-{- Generates Remote configuration for encryption. -}
-configureEncryption :: EnableEncryption -> (RemoteConfigKey, String)
-configureEncryption SharedEncryption = ("encryption", "shared")
-configureEncryption NoEncryption = ("encryption", "none")
-configureEncryption HybridEncryption = ("encryption", "hybrid")

Assistant/WebApp/Gpg.hs

@@ -10,8 +10,8 @@
 module Assistant.WebApp.Gpg where
 
 import Assistant.WebApp.Common
+import Assistant.Gpg
 import Utility.Gpg
-import Utility.UserInfo
 import qualified Git.Command
 import qualified Git.Remote
 import qualified Annex.Branch
@@ -31,15 +31,14 @@ gpgKeyDisplay keyid userid = [whamlet|
         key id #{keyid}
 |]
 
-{- Generates a gpg user id that is not used by any existing secret key -}
-newUserId :: IO UserId
-newUserId = do
-	oldkeys <- secretKeys
-	username <- myUserName
-  	let basekeyname = username ++ "'s git-annex encryption key"
-	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
-		( basekeyname
-		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
+genKeyModal :: Widget
+genKeyModal = $(widgetFile "configurators/genkeymodal")
+
+whenGcryptInstalled :: Handler Html -> Handler Html
+whenGcryptInstalled a = ifM (liftIO $ inPath "git-remote-gcrypt")
+	( a
+	, page "Need git-remote-gcrypt" (Just Configuration) $
+		$(widgetFile "configurators/needgcrypt")
 	)
 
 withNewSecretKey :: (KeyId -> Handler Html) -> Handler Html
@@ -73,9 +72,3 @@ getGCryptRemoteName u repoloc = do
 	void $ inRepo $ Git.Remote.remove tmpremote
 	return mname
 
-whenGcryptInstalled :: Handler Html -> Handler Html
-whenGcryptInstalled a = ifM (liftIO $ inPath "git-remote-gcrypt")
-	( a
-	, page "Need git-remote-gcrypt" (Just Configuration) $
-		$(widgetFile "configurators/needgcrypt")
-	)

Assistant/WebApp/routes

@@ -45,6 +45,8 @@
 /config/repository/add/ssh/make/git/#SshData MakeSshGitR GET
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR 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
 /config/repository/add/cloud/S3 AddS3R GET POST
 /config/repository/add/cloud/IA AddIAR GET POST
 /config/repository/add/cloud/glacier AddGlacierR GET POST

debian/changelog

@@ -17,6 +17,7 @@ git-annex (4.20130921) UNRELEASED; urgency=low
     the user running the conversion.
   * add, import, assistant: Better preserve the mtime of symlinks,
     when when adding content that gets deduplicated.
+  * webapp: Support storing encrypted git repositories on rsync.net.
 
  -- Joey Hess <joeyh@debian.org>  Sun, 22 Sep 2013 19:42:29 -0400
 

templates/configurators/rsync.net/add.hamlet

@@ -27,14 +27,14 @@
         ^{form}
         ^{webAppFormAuthToken}
         <div .form-actions>
-          <button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');">
+          <button .btn .btn-primary type=submit onclick="$('#setupmodal').modal('show');">
             Use this rsync.net repository
-<div .modal .fade #testmodal>
+<div .modal .fade #setupmodal>
   <div .modal-header>
     <h3>
-      Making repository ...
+      Checking access to rsync.net ...
   <div .modal-body>
     <p>
-      Setting up your rsync.net repository. This could take a minute.
+      This could take a minute.
     <p>
       You may be prompted for your rsync.net ssh password.

templates/configurators/rsync.net/encrypt.hamlet

@@ -0,0 +1,43 @@
+<div .span9 .hero-unit>
+  <h2>
+    Ready to use rsync.net
+  <p>
+    All data will be encrypted before it is sent to rsync.net. #
+    There are two options for how to encrypt your data.
+  <h3>
+    Simple shared encryption
+  <p>
+    This allows everyone who has a clone of this repository to decrypt the #
+    files stored on rsync.net. That makes it good for sharing. #
+    And it's easy to set up and use.
+  <p>
+    <a .btn href="@{MakeRsyncNetSharedR sshdata}" onclick="$('#setupmodal').modal('show');">
+      <i .icon-lock></i> Use shared encryption
+  <p style="text-align: center">
+    -or-
+  <h3>
+    Encrypt with GnuPG key
+  <p>
+    This stores an encrypted clone of your repository on rsync.net, #
+    unlike shared encryption which only stores file contents on rsync.net. #
+    So it's good for backups. But the encryption will prevent you from #
+    sharing the rsync.net repository with friends, or easily accessing #
+    its contents on another computer.
+  <p>
+    $forall (keyid, name) <- secretkeys
+      <p>
+        <a .btn onclick="$('#setupmodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata (RepoKey keyid)}">
+          <i .icon-lock></i> Encrypt repository #
+        to ^{gpgKeyDisplay keyid (Just name)}
+  <p>
+    <a .btn onclick="$('#genkeymodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata NoRepoKey}">
+      <i .icon-plus-sign></i> Encrypt repository #
+    with a new encryption key
+^{genKeyModal}
+<div .modal .fade #setupmodal>
+  <div .modal-header>
+    <h3>
+      Making repository ...
+  <div .modal-body>
+    <p>
+      Setting up your rsync.net repository. This could take a minute.