assistant: Retrival from glacier now handled.

Assistant.hs

@@ -74,6 +74,8 @@
  - Thread 20: WebApp
  - 	Spawns more threads as necessary to handle clients.
  - 	Displays the DaemonStatus.
+ - Thread 21: Glacier
+ - 	Deals with retrieving files from Amazon Glacier.
  -
  - ThreadState: (MVar)
  - 	The Annex state is stored here, which allows resuscitating the
@@ -136,6 +138,7 @@ import Assistant.Threads.NetWatcher
 import Assistant.Threads.TransferScanner
 import Assistant.Threads.TransferPoller
 import Assistant.Threads.ConfigMonitor
+import Assistant.Threads.Glacier
 #ifdef WITH_WEBAPP
 import Assistant.WebApp
 import Assistant.Threads.WebApp
@@ -208,6 +211,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 			, assist $ netWatcherFallbackThread
 			, assist $ transferScannerThread
 			, assist $ configMonitorThread
+			, assist $ glacierThread
 			, watch $ watchThread
 			]
 		liftIO waitForTermination

Assistant/Threads/Glacier.hs

@@ -0,0 +1,43 @@
+{- git-annex assistant Amazon Glacier retrieval
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Threads.Glacier where
+
+import Assistant.Common
+import Utility.ThreadScheduler
+import qualified Types.Remote as Remote
+import qualified Remote.Glacier as Glacier
+import Logs.Transfer
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+
+import qualified Data.Set as S
+
+{- Wakes up every half hour and checks if any glacier remotes have failed
+ - downloads. If so, runs glacier-cli to check if the files are now
+ - available, and queues the downloads. -}
+glacierThread :: NamedThread
+glacierThread = NamedThread "Glacier" $ runEvery (Seconds 3600) <~> go
+  where
+	isglacier r = Remote.remotetype r == Glacier.remote
+	go = do
+		rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus
+		forM_ rs $ \r -> 
+			check r =<< (liftAnnex $ getFailedTransfers $ Remote.uuid r)
+	check _ [] = noop
+	check r l = do
+		let keys = map getkey l
+		(availkeys, failedkeys) <- liftAnnex $ Glacier.jobList r keys
+		let s = S.fromList (failedkeys ++ availkeys)
+		let l' = filter (\p -> S.member (getkey p) s) l
+		forM_ l' $ \(t, info) -> do
+			liftAnnex $ removeFailedTransfer t
+			queueTransferWhenSmall (associatedFile info) t r
+	getkey = transferKey . fst

Remote/Glacier.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Remote.Glacier (remote) where
+module Remote.Glacier (remote, jobList) where
 
 import qualified Data.Map as M
 import System.Environment
@@ -232,10 +232,10 @@ glacierEnv c u = go =<< getRemoteCredPairFor "glacier" c creds
 	(uk, pk) = credPairEnvironment creds
 
 remoteVault :: Remote -> Vault
-remoteVault = vault . fromJust . config
+remoteVault = getVault . fromJust . config
 
-vault :: RemoteConfig -> Vault
-vault = fromJust . M.lookup "vault"
+getVault :: RemoteConfig -> Vault
+getVault = fromJust . M.lookup "vault"
 
 archive :: Remote -> Key -> Archive
 archive r k = fileprefix ++ key2file k
@@ -250,5 +250,50 @@ genVault c u = unlessM (runGlacier c u params) $
 	params = 
 		[ Param "vault"
 		, Param "create"
-		, Param $ vault c
+		, Param $ getVault c
 		]
+
+{- Partitions the input list of keys into ones which have
+ - glacier retieval jobs that have succeeded, or failed.
+ -
+ - A complication is that `glacier job list` will display the encrypted
+ - keys when the remote is encrypted.
+ -}
+jobList :: Remote -> [Key] -> Annex ([Key], [Key])
+jobList r keys = go =<< glacierEnv (fromJust $ config r) (uuid r)
+  where
+	params = [ Param "job", Param "list" ]
+	nada = ([], [])
+	myvault = remoteVault r
+
+	go Nothing = return nada
+	go (Just e) = do
+		v <- liftIO $ catchMaybeIO $ 
+			readProcessEnv "glacier" (toCommand params) (Just e)
+		maybe (return nada) extract v
+
+	extract s = do
+		let result@(succeeded, failed) =
+			parse nada $ (map words . lines) s
+		if result == nada
+			then return nada
+			else do
+				enckeys <- forM keys $ \k ->
+					maybe k snd <$> cipherKey (config r) k
+				let keymap = M.fromList $ zip enckeys keys
+				let convert = catMaybes . map (`M.lookup` keymap)
+				return (convert succeeded, convert failed)
+
+	parse c [] = c
+	parse c@(succeeded, failed) ((status:_date:vault:key:[]):rest)
+		| vault == myvault =
+			case file2key key of
+				Nothing -> parse c rest
+				Just k
+					| "a/d" `isPrefixOf` status ->
+						parse (k:succeeded, failed) rest
+					| "a/e" `isPrefixOf` status ->
+						parse (succeeded, k:failed) rest
+					| otherwise ->
+						parse c rest
+	parse c (_:rest) = parse c rest

debian/changelog

@@ -3,6 +3,7 @@ git-annex (3.20121128) UNRELEASED; urgency=low
   * webapp: Defaults to sharing box.com account info with friends, allowing
     one-click enabling of the repository.
   * Fix broken .config/git-annex/program installed by standalone tarball.
+  * assistant: Retrival from glacier now handled.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 28 Nov 2012 13:31:07 -0400