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

-- | 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 -> StorageLocations
uploadQueueLocations (StorageLocations servers) = StorageLocations $
	map (localStorage . ("uploadqueue" </>) . show)
		[1..length servers]

localStorageLocations :: StorageLocations
localStorageLocations = StorageLocations $
	map (localStorage . ("local" </>) . show)
		[1..100 :: Int]

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' rest shards'