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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{- git-annex assistant data transferrer thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Transferrer where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Alert
import Assistant.Commits
import Assistant.Drop
import Logs.Transfer
import Logs.Location
import Annex.Content
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git
import Types.Key
import Locations.UserConfig
import Assistant.Threads.TransferWatcher
import Annex.Wanted
import System.Process (create_group)
{- Dispatches transfers from the queue. -}
transfererThread :: NamedThread
transfererThread = namedThread "Transferrer" $ do
program <- liftIO readProgramFile
forever $ inTransferSlot $
maybe (return Nothing) (uncurry $ startTransfer program)
=<< getNextTransfer notrunning
where
{- Skip transfers that are already running. -}
notrunning = isNothing . startedTime
{- By the time this is called, the daemonstatus's currentTransfers map should
- already have been updated to include the transfer. -}
startTransfer
:: FilePath
-> Transfer
-> TransferInfo
-> Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
startTransfer program t info = case (transferRemote info, associatedFile info) of
(Just remote, Just file)
| Git.repoIsLocalUnknown (Remote.repo remote) -> do
-- optimisation for removable drives not plugged in
liftAnnex $ recordFailedTransfer t info
void $ removeTransfer t
return Nothing
| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
( do
debug [ "Transferring:" , describeTransfer t info ]
notifyTransfer
return $ Just (t, info, transferprocess remote file)
, do
debug [ "Skipping unnecessary transfer:",
describeTransfer t info ]
void $ removeTransfer t
finishedTransfer t (Just info)
return Nothing
)
_ -> return Nothing
where
direction = transferDirection t
isdownload = direction == Download
transferprocess remote file = void $ do
(_, _, _, pid)
<- liftIO $ createProcess
(proc program $ toCommand params)
{ create_group = True }
{- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons,
- so there's no point in bothering the user about
- those. The assistant should recover.
-
- After a successful upload, handle dropping it from
- here, if desired. In this case, the remote it was
- uploaded to is known to have it.
-
- Also, after a successful transfer, the location
- log has changed. Indicate that a commit has been
- made, in order to queue a push of the git-annex
- branch out to remotes that did not participate
- in the transfer.
-
- If the process failed, it could have crashed,
- so remove the transfer from the list of current
- transfers, just in case it didn't stop
- in a way that lets the TransferWatcher do its
- usual cleanup.
-}
ifM (liftIO $ (==) ExitSuccess <$> waitForProcess pid)
( do
void $ addAlert $ makeAlertFiller True $
transferFileAlert direction True file
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
True (transferKey t)
(associatedFile info)
(Just remote)
recordCommit
, void $ removeTransfer t
)
where
params =
[ Param "transferkey"
, Param "--quiet"
, Param $ key2file $ transferKey t
, Param $ if isdownload
then "--from"
else "--to"
, Param $ Remote.name remote
, Param "--file"
, File file
]
{- Called right before a transfer begins, this is a last chance to avoid
- unnecessary transfers.
-
- For downloads, we obviously don't need to download if the already
- have the object.
-
- Smilarly, for uploads, check if the remote is known to already have
- the object.
-
- Also, uploads get queued to all remotes, in order of cost.
- This may mean, for example, that an object is uploaded over the LAN
- to a locally paired client, and once that upload is done, a more
- expensive transfer remote no longer wants the object. (Since
- all the clients have it already.) So do one last check if this is still
- preferred content.
-
- We'll also do one last preferred content check for downloads. An
- example of a case where this could be needed is if a download is queued
- for a file that gets moved out of an archive directory -- but before
- that download can happen, the file is put back in the archive.
-}
shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
shouldTransfer t info
| transferDirection t == Download =
(not <$> inAnnex key) <&&> wantGet True file
| transferDirection t == Upload = case transferRemote info of
Nothing -> return False
Just r -> notinremote r
<&&> wantSend True file (Remote.uuid r)
| otherwise = return False
where
key = transferKey t
file = associatedFile info
{- Trust the location log to check if the remote already has
- the key. This avoids a roundtrip to the remote. -}
notinremote r = notElem (Remote.uuid r) <$> loggedLocations key
|
