summaryrefslogtreecommitdiff
path: root/Assistant/Threads/Glacier.hs
blob: 4c4012a6763f474c91497dcc07dc30794c0a2316 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
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 "object available from glacier" (associatedFile info) t r
	getkey = transferKey . fst