webapp gpg key generation

Now the webapp can generate a gpg key that is dedicated for use by
git-annex. Since the key is single use, much of the complexity of
generating gpg keys is avoided.

Note that the key has no password, because gpg-agent is not available
everywhere the assistant is installed. This is not a big security problem
because the key is going to live on the same disk as the git annex
repository, so an attacker with access to it can look directly in the
repository to see the same files that get stored in the encrypted
repository on the removable drive.

There is no provision yet for backing up keys.

This commit sponsored by Robert Beaty.

Assistant/WebApp/Configurators/Local.hs

@@ -265,21 +265,50 @@ getConfirmAddDriveR drive = ifM (liftIO $ doesDirectoryExist dir)
 			<$> liftIO secretKeys
 		page "Encrypt repository?" (Just Configuration) $
 			$(widgetFile "configurators/adddrive/encrypt")
-	knownrepo = getFinishAddDriveR (RemovableDriveKey drive Nothing)
+	knownrepo = getFinishAddDriveR drive NoRepoKey
 	askcombine = page "Combine repositories?" (Just Configuration) $
 		$(widgetFile "configurators/adddrive/combine")
 
 setupDriveModal :: Widget
 setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")
 
-getFinishAddDriveR :: RemovableDriveKey -> Handler Html
-getFinishAddDriveR (RemovableDriveKey drive mkeyid) =
-	maybe setupclear setupencrypted mkeyid
+genKeyModal :: Widget
+genKeyModal = $(widgetFile "configurators/genkeymodal")
+
+getGenKeyForDriveR :: RemovableDrive -> Handler Html
+getGenKeyForDriveR drive = do
+	userid <- liftIO $ newUserId
+	liftIO $ genSecretKey RSA "" userid maxRecommendedKeySize
+	results <- M.keys . M.filter (== userid) <$> liftIO secretKeys
+	case results of
+		[] -> error "Failed to generate gpg key!"
+		(key:_) -> 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)
+				, getAddDriveR
+				)
+
+newUserId :: IO UserId
+newUserId = do
+	oldkeys <- secretKeys
+	username <- myUserName
+  	let basekeyname = username ++ " git-annex"
+	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
+		( basekeyname
+		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
+		)
+
+getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
+getFinishAddDriveR drive = go
   where
-	setupclear = makewith $ \isnew -> (,)
+	go NoRepoKey = makewith $ \isnew -> (,)
 		<$> liftIO (initRepo isnew False dir $ Just remotename)
 		<*> combineRepos dir remotename
-	setupencrypted keyid = ifM (liftIO $ inPath "git-remote-gcrypt")
+	go (RepoKey keyid) = ifM (liftIO $ inPath "git-remote-gcrypt")
 		( makewith $ \_ -> do
 			r <- liftAnnex $ addRemote $ 
 				initSpecialRemote remotename GCrypt.remote $ M.fromList

Assistant/WebApp/Types.hs

@@ -160,7 +160,7 @@ data RemovableDrive = RemovableDrive
 	}
 	deriving (Read, Show, Eq, Ord)
 
-data RemovableDriveKey = RemovableDriveKey RemovableDrive (Maybe KeyId)
+data RepoKey = RepoKey KeyId | NoRepoKey
 	deriving (Read, Show, Eq, Ord)
 
 {- Only needed to work around old-yesod bug that emits a warning message
@@ -176,7 +176,7 @@ instance PathPiece RemovableDrive where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
 
-instance PathPiece RemovableDriveKey where
+instance PathPiece RepoKey where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
 

Assistant/WebApp/routes

@@ -37,7 +37,8 @@
 
 /config/repository/add/drive AddDriveR GET POST
 /config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET
-/config/repository/add/drive/finish/#RemovableDriveKey FinishAddDriveR GET
+/config/repository/add/drive/genkey/#RemovableDrive GenKeyForDriveR GET
+/config/repository/add/drive/finish/#RemovableDrive/#RepoKey FinishAddDriveR GET
 /config/repository/add/ssh AddSshR GET POST
 /config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
 /config/repository/add/ssh/retry/#SshData RetrySshR GET