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
|
{- 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 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)
|
