diff options
| -rw-r--r-- | Assistant.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/Glacier.hs | 43 | ||||
| -rw-r--r-- | Remote/Glacier.hs | 55 | ||||
| -rw-r--r-- | debian/changelog | 1 |
4 files changed, 98 insertions, 5 deletions
diff --git a/Assistant.hs b/Assistant.hs index 5b3dd9cb9..a0d4ed2ff 100644 --- a/Assistant.hs +++ b/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 diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs new file mode 100644 index 000000000..3ccb57cbe --- /dev/null +++ b/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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 55b704a33..a4d658d1b 100644 --- a/Remote/Glacier.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index e2bdd6046..36c066998 100644 --- a/debian/changelog +++ b/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 |