summaryrefslogtreecommitdiff
path: root/Assistant/Threads/Glacier.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/Threads/Glacier.hs')
-rw-r--r--Assistant/Threads/Glacier.hs43
1 files changed, 43 insertions, 0 deletions
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