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
|
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Storage (module Storage, module Types.Storage) where
import Types
import Types.Storage
import Share
import Storage.Local
import Storage.Network
import Servers
import Data.Monoid
import Data.Maybe
import System.FilePath
import Control.Monad
import qualified Data.Set as S
allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations
allStorageLocations d = do
servers <- networkServers
return $ StorageLocations $
map networkStorage servers <> map (uploadQueue d) servers
localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations
localStorageLocations d = StorageLocations $
map (localStorage (storageDir d) . ("local" </>) . show)
[1..100 :: Int]
type UpdateProgress = IO ()
-- | Stores the shares amoung the storage locations. Each location
-- gets at most one share from each set.
--
-- TODO: Add shuffling and queueing/chaffing to prevent
-- correlation of related shares.
storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO StoreResult
storeShares (StorageLocations locs) allsis shares updateprogress = do
(r, usedlocs) <- go allsis shares []
_ <- mapM_ obscureShares usedlocs
return r
where
go sis (s:rest) usedlocs = do
let (is, sis') = nextShareIdents sis
(r, usedlocs') <- storeset locs [] Nothing (zip (S.toList is) (S.toList s))
case r of
StoreSuccess -> go sis' rest (usedlocs ++ usedlocs')
_ -> return (r, usedlocs ++ usedlocs')
go _ [] usedlocs = return (StoreSuccess, usedlocs)
storeset _ usedlocs _ [] = return (StoreSuccess, usedlocs)
storeset [] usedlocs lasterr _ =
return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs)
storeset (loc:otherlocs) usedlocs _ ((i, s):rest) = do
r <- storeShare loc i s
case r of
StoreSuccess -> do
_ <- updateprogress
storeset otherlocs (loc:usedlocs) Nothing rest
-- Give up if any location complains a share
-- already exists, because we have a name conflict.
StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs)
-- Try storing it somewhere else on failure.
StoreFailure _ ->
storeset otherlocs usedlocs (Just r) ((i, s):rest)
-- | Retrieves one set of shares from the storage locations.
-- Returns all the shares it can find, which may not be enough,
-- and the remaining Shareidents, to use to get subsequent sets.
--
-- Assumes that each location only contains one share. So, once a
-- share has been found on a location, can avoid asking that location
-- for any other shares.
retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents)
retrieveShares (StorageLocations locs) sis updateprogress = do
let (is, sis') = nextShareIdents sis
let want = zip [1..] (S.toList is)
(shares, usedlocs, _unusedlocs) <- go locs [] want []
_ <- mapM_ obscureShares usedlocs
return (S.fromList shares, sis')
where
go unusedlocs usedlocs [] shares = return (shares, usedlocs, unusedlocs)
go [] usedlocs _ shares = return (shares, usedlocs, [])
go (loc:otherlocs) usedlocs ((n, i):rest) shares = do
r <- retrieveShare loc n i
case r of
RetrieveSuccess s -> do
_ <- updateprogress
go otherlocs (loc:usedlocs) rest (s:shares)
RetrieveFailure _ -> do
-- Try to get the share from other locations.
(shares', usedlocs', unusedlocs) <-
go otherlocs usedlocs [(n, i)] shares
-- May need to ask the location that didn't
-- have the share for a later share, but
-- ask it last. This way, the first
-- location on the list can't deny having
-- all shares and so learn the idents of
-- all of them.
go (unusedlocs++[loc]) usedlocs' rest shares'
uploadQueued :: Maybe LocalStorageDirectory -> IO ()
uploadQueued d = do
servers <- networkServers
forM_ servers $ \s -> moveShares (uploadQueue d s) (networkStorage s)
|
