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
|
{- 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 Shard
import Storage.Local
import Storage.Network
import System.FilePath
import Data.Monoid
import Data.Maybe
allStorageLocations :: IO StorageLocations
allStorageLocations = do
servers <- networkServers
return $ servers <> uploadQueueLocations
-- | Objects queued for upload to servers. There are a number of queues,
-- but no 1:1 mapping from queues to a particular server.
-- It's important that when flushing the upload queue, the objects in each
-- separate queue are sent to a separate server.
uploadQueueLocations :: StorageLocations
uploadQueueLocations = StorageLocations $
map (localStorage . ("uploadqueue" </>) . show) ([1..] :: [Integer])
localStorageLocations :: StorageLocations
localStorageLocations = StorageLocations $
map (localStorage . ("local" </>) . show) ([1..] :: [Integer])
type UpdateProgress = IO ()
-- | Stores the shards amoung the storage locations. Each location
-- gets at most one shard.
storeShards :: StorageLocations -> ShardIdents -> [(UpdateProgress, Shard)] -> IO StoreResult
storeShards (StorageLocations locs) sis shards = do
(r, usedlocs) <- go locs [] Nothing (zip (getIdents sis) shards)
_ <- mapM_ obscureShards 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 <- storeShard loc i s
case r of
StoreSuccess -> do
_ <- showprogress
go otherlocs (loc:usedlocs) Nothing rest
_ -> go otherlocs usedlocs (Just r) tostore
-- | Retrieves shards from among the storage locations, and returns all
-- the shards it can find, which may not be all that were requested.
--
-- Assumes that each location only contains one shard. So, once a
-- shard has been found on a location, can avoid asking that location
-- for any other shards.
retrieveShards :: StorageLocations -> [(UpdateProgress, (ShardNum, StorableObjectIdent))] -> IO [Shard]
retrieveShards (StorageLocations locs) l = do
(shards, usedlocs, _unusedlocs) <- go locs [] l []
_ <- mapM_ obscureShards usedlocs
return shards
where
go unusedlocs usedlocs [] shards = return (shards, usedlocs, unusedlocs)
go [] usedlocs _ shards = return (shards, usedlocs, [])
go (loc:otherlocs) usedlocs toretrieve@((updateprogress, (n, i)):rest) shards = do
r <- retrieveShard loc n i
case r of
RetrieveSuccess s -> do
_ <- updateprogress
go otherlocs (loc:usedlocs) rest (s:shards)
RetrieveFailure _ -> do
(shards', usedlocs', unusedlocs) <-
go otherlocs usedlocs toretrieve shards
-- May need to ask the location that didn't
-- have the shard for a later shard, but
-- ask it last. This way, the first
-- location on the list can't deny having
-- all shards and so learn the idents of
-- all of them.
go (unusedlocs++[loc]) usedlocs' toretrieve shards'
|
