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

Utility/Gpg.hs

@@ -172,6 +172,11 @@ type Passphrase = String
 type Size = Int
 data KeyType = Algo Int | DSA | RSA
 
+{- The maximum key size that gpg currently offers in its UI when
+ - making keys. -}
+maxRecommendedKeySize :: Size
+maxRecommendedKeySize = 4096
+
 {- Generates a secret key using the experimental batch mode.
  - The key is added to the secret key ring.
  - Can take a very long time, depending on system entropy levels.
@@ -182,16 +187,18 @@ genSecretKey keytype passphrase userid keysize =
   where
 	params = ["--batch", "--gen-key"]
   	feeder h = do
-		hPutStr h $ unlines
-			[ "Key-Type: " ++ 
+		hPutStr h $ unlines $ catMaybes
+			[ Just $  "Key-Type: " ++ 
 				case keytype of
 					DSA -> "DSA"
 					RSA -> "RSA"
 					Algo n -> show n
-			, "Key-Length: " ++ show keysize
-			, "Name-Real: " ++ userid
-			, "Expire-Date: 0"
-			, "Passphrase: " ++ passphrase
+			, Just $ "Key-Length: " ++ show keysize
+			, Just $ "Name-Real: " ++ userid
+			, Just $ "Expire-Date: 0"
+			, if null passphrase
+				then Nothing
+				else Just $ "Passphrase: " ++ passphrase
 			]
 		hClose h
 

templates/configurators/adddrive/combine.hamlet

@@ -7,7 +7,7 @@
   <p>
     Do you want to combine these files into your repository?
   <p>
-    <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR (RemovableDriveKey drive Nothing)}">
+    <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR drive NoRepoKey}">
       <i .icon-resize-small></i> Combine the repositories #
     The combined repositories will sync and share their files.
   <p>

templates/configurators/adddrive/encrypt.hamlet

@@ -9,12 +9,12 @@
     will also prevent you from sharing the repository with friends, or #
     easily accessing its contents on another computer.
   <p>
-    <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR (RemovableDriveKey drive Nothing)}">
+    <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR drive NoRepoKey}">
       <i .icon-minus-sign></i> Do not encrypt repository #
     Anyone who has the drive can see the files stored on it.
     $forall (keyid, name) <- secretkeys
       <p>
-        <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR (RemovableDriveKey drive (Just keyid))}">
+        <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR drive (RepoKey keyid)}">
           <i .icon-ok-sign></i> Encrypt repository #
         to
         <span title="key id #{keyid}">
@@ -24,7 +24,8 @@
           $else
             #{name}
   <p>
-    <a .btn href="">
+    <a .btn onclick="$('#genkeymodal').modal('show');" href="@{GenKeyForDriveR drive}">
       <i .icon-plus-sign></i> Encrypt repository #
     with a new encryption key
 ^{setupDriveModal}
+^{genKeyModal}

templates/configurators/genkeymodal.hamlet

@@ -0,0 +1,12 @@
+<div .modal .fade #genkeymodal>
+  <div .modal-header>
+    <h3>
+      <img src="@{StaticR activityicon_gif}" alt=""> #
+      Generating a #{maxRecommendedKeySize} bit GnuPg key.
+  <div .modal-body>
+    <p>
+      Generating a GnuPg key can take a long time. To speed up the process, #
+      it actually helps to use your computer for other things, which helps #
+      generate random numbers that keep the GnuPg key secure.
+    <p>
+      So if this is taking too long, go play a game or something!