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
|
{- 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
allStorageLocations :: IO StorageLocations
allStorageLocations = do
servers <- networkServers
return $ StorageLocations $
map networkStorage servers <> map uploadQueue servers
localStorageLocations :: StorageLocations
localStorageLocations = StorageLocations $
map (localStorage . ("local" </>) . show)
[1..100 :: Int]
type UpdateProgress = IO ()
-- | Stores the shares amoung the storage locations. Each location
-- gets at most one share.
storeShares :: StorageLocations -> ShareIdents -> [(UpdateProgress, Share)] -> IO StoreResult
storeShares (StorageLocations locs) sis shares = do
(r, usedlocs) <- go locs [] Nothing (zip (getIdents sis) shares)
_ <- mapM_ obscureShares usedlocs
return r
where
go _ usedlocs _ [] = return (StoreSuccess, usedlocs)
go [] usedlocs lasterr _ =
return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs)
go (loc:otherlocs) usedlocs _ tostore@((i,(showprogress, s)):rest) = do
r <- storeShare loc i s
case r of
StoreSuccess -> do
_ <- showprogress
go otherlocs (loc:usedlocs) Nothing rest
StoreFailure _ -> go otherlocs usedlocs (Just r) tostore
-- Give up if any location complains a share
-- already exists, because we have a name conflict.
StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs)
-- | Retrieves shares from among the storage locations, and returns all
-- the shares it can find, which may not be all that were requested.
--
-- 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 -> [(UpdateProgress, (ShareNum, StorableObjectIdent))] -> IO [Share]
retrieveShares (StorageLocations locs) l = do
(shares, usedlocs, _unusedlocs) <- go locs [] l []
_ <- mapM_ obscureShares usedlocs
return shares
where
go unusedlocs usedlocs [] shares = return (shares, usedlocs, unusedlocs)
go [] usedlocs _ shares = return (shares, usedlocs, [])
go (loc:otherlocs) usedlocs (toretrieve@(updateprogress, (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
(shares', usedlocs', unusedlocs) <-
go otherlocs usedlocs [toretrieve] 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 :: IO ()
uploadQueued = do
servers <- networkServers
forM_ servers $ \s -> moveShares (uploadQueue s) (networkStorage s)
|
