{-# LANGUAGE FlexibleInstances #-}

module TahoeLAFS.Storage.Backend.Memory (
    MemoryBackend (MemoryBackend),
    memoryBackend,
    MutableShareSize (..),
    shareDataSize,
    toMutableShareSize,
) where

import Control.Exception (
    throw,
    throwIO,
 )
import Control.Foldl.ByteString (Word8)
import Data.ByteArray (constEq)
import qualified Data.ByteString as B
import Data.IORef (
    IORef,
    atomicModifyIORef',
    modifyIORef,
    newIORef,
    readIORef,
 )
import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid (Last (Last, getLast))
import qualified Data.Set as Set
import Network.HTTP.Types (ByteRange (ByteRangeFrom, ByteRangeFromTo, ByteRangeSuffix))
import TahoeLAFS.Storage.API (
    AllocateBuckets (AllocateBuckets),
    AllocationResult (..),
    CBORSet (..),
    Offset,
    QueryRange,
    ReadTestWriteResult (..),
    ReadTestWriteVectors (..),
    ReadVector (ReadVector, offset, readSize),
    ShareData,
    ShareNumber,
    Size,
    StorageIndex,
    TestWriteVectors (..),
    UploadSecret (UploadSecret),
    Version (..),
    Version1Parameters (..),
    WriteEnablerSecret (WriteEnablerSecret),
    WriteVector (..),
 )
import TahoeLAFS.Storage.Backend (
    Backend (..),
    WriteImmutableError (ImmutableShareAlreadyWritten, IncorrectUploadSecret, IncorrectWriteEnablerSecret, ShareNotAllocated, ShareSizeMismatch),
    withUploadSecret,
 )
import Prelude hiding (
    lookup,
    map,
 )

data ImmutableShare = Complete ShareData | Uploading UploadSecret ShareData

data Bucket = Bucket
    { Bucket -> Size
bucketSize :: Size
    , Bucket -> Map ShareNumber ImmutableShare
bucketShares :: Map.Map ShareNumber ImmutableShare
    }

data SecretProtected a = SecretProtected WriteEnablerSecret a

readSecret :: SecretProtected a -> WriteEnablerSecret
readSecret :: SecretProtected a -> WriteEnablerSecret
readSecret (SecretProtected WriteEnablerSecret
s a
_) = WriteEnablerSecret
s

readProtected :: SecretProtected a -> a
readProtected :: SecretProtected a -> a
readProtected (SecretProtected WriteEnablerSecret
_ a
p) = a
p

{- | Apply a function in a SecretProtected to a value in a SecretProtected.  The
 result is in SecretProtected with the function's secret.

 This is almost liftA2 but it's not clear to me how to have lawful handling of
 the secret.
-}
liftProtected2 :: (a -> a -> a) -> SecretProtected a -> SecretProtected a -> SecretProtected a
liftProtected2 :: (a -> a -> a)
-> SecretProtected a -> SecretProtected a -> SecretProtected a
liftProtected2 a -> a -> a
f (SecretProtected WriteEnablerSecret
secretL a
x) (SecretProtected WriteEnablerSecret
_ a
y) = WriteEnablerSecret -> a -> SecretProtected a
forall a. WriteEnablerSecret -> a -> SecretProtected a
SecretProtected WriteEnablerSecret
secretL (a -> a -> a
f a
x a
y)

instance Functor SecretProtected where
    fmap :: (a -> b) -> SecretProtected a -> SecretProtected b
fmap a -> b
f (SecretProtected WriteEnablerSecret
secret a
a) = WriteEnablerSecret -> b -> SecretProtected b
forall a. WriteEnablerSecret -> a -> SecretProtected a
SecretProtected WriteEnablerSecret
secret (a -> b
f a
a)

type MutableShareStorage = Map.Map StorageIndex (SecretProtected (Map.Map ShareNumber [WriteVector]))

data MutableShareSize = MutableShareSize Offset Size deriving (Int -> MutableShareSize -> ShowS
[MutableShareSize] -> ShowS
MutableShareSize -> String
(Int -> MutableShareSize -> ShowS)
-> (MutableShareSize -> String)
-> ([MutableShareSize] -> ShowS)
-> Show MutableShareSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MutableShareSize] -> ShowS
$cshowList :: [MutableShareSize] -> ShowS
show :: MutableShareSize -> String
$cshow :: MutableShareSize -> String
showsPrec :: Int -> MutableShareSize -> ShowS
$cshowsPrec :: Int -> MutableShareSize -> ShowS
Show, MutableShareSize -> MutableShareSize -> Bool
(MutableShareSize -> MutableShareSize -> Bool)
-> (MutableShareSize -> MutableShareSize -> Bool)
-> Eq MutableShareSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MutableShareSize -> MutableShareSize -> Bool
$c/= :: MutableShareSize -> MutableShareSize -> Bool
== :: MutableShareSize -> MutableShareSize -> Bool
$c== :: MutableShareSize -> MutableShareSize -> Bool
Eq)

instance Semigroup MutableShareSize where
    (MutableShareSize Size
writeOffsetL Size
sizeL) <> :: MutableShareSize -> MutableShareSize -> MutableShareSize
<> (MutableShareSize Size
writeOffsetR Size
sizeR) =
        Size -> Size -> MutableShareSize
MutableShareSize Size
minOffset Size
maxSize
      where
        minOffset :: Size
minOffset = Size -> Size -> Size
forall a. Ord a => a -> a -> a
min Size
writeOffsetL Size
writeOffsetR
        maxSize :: Size
maxSize = Size -> Size -> Size
forall a. Ord a => a -> a -> a
max (Size
writeOffsetL Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sizeL) (Size
writeOffsetR Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
sizeR) Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
minOffset

instance Monoid MutableShareSize where
    mempty :: MutableShareSize
mempty = Size -> Size -> MutableShareSize
MutableShareSize Size
0 Size
0

toMutableShareSize :: WriteVector -> MutableShareSize
toMutableShareSize :: WriteVector -> MutableShareSize
toMutableShareSize (WriteVector Size
offset ShareData
bytes) = Size -> Size -> MutableShareSize
MutableShareSize Size
offset (Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ ShareData -> Int
B.length ShareData
bytes)

shareDataSize :: [WriteVector] -> Size
shareDataSize :: [WriteVector] -> Size
shareDataSize [WriteVector]
writev = Size
offset Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
size
  where
    (MutableShareSize Size
offset Size
size) = (WriteVector -> MutableShareSize)
-> [WriteVector] -> MutableShareSize
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap WriteVector -> MutableShareSize
toMutableShareSize [WriteVector]
writev

data MemoryBackend = MemoryBackend
    { MemoryBackend -> Map String Bucket
memoryBackendBuckets :: Map.Map StorageIndex Bucket -- Completely or partially written immutable share data
    , MemoryBackend -> MutableShareStorage
mutableShares :: MutableShareStorage -- Completely written mutable shares
    }

getShareNumbers :: StorageIndex -> MemoryBackend -> CBORSet ShareNumber
getShareNumbers :: String -> MemoryBackend -> CBORSet ShareNumber
getShareNumbers String
storageIndex MemoryBackend
backend = CBORSet ShareNumber
shareSet
  where
    shareSet :: CBORSet ShareNumber
shareSet = Set ShareNumber -> CBORSet ShareNumber
forall a. Set a -> CBORSet a
CBORSet (Set ShareNumber -> CBORSet ShareNumber)
-> ([ShareNumber] -> Set ShareNumber)
-> [ShareNumber]
-> CBORSet ShareNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShareNumber] -> Set ShareNumber
forall a. Ord a => [a] -> Set a
Set.fromList ([ShareNumber] -> CBORSet ShareNumber)
-> [ShareNumber] -> CBORSet ShareNumber
forall a b. (a -> b) -> a -> b
$ [ShareNumber]
shareNumbers
    shareNumbers :: [ShareNumber]
shareNumbers = case String -> Map String Bucket -> Maybe Bucket
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex (MemoryBackend -> Map String Bucket
memoryBackendBuckets MemoryBackend
backend) of
        Maybe Bucket
Nothing -> [ShareNumber]
forall a. Monoid a => a
mempty
        Just Bucket
bucket -> Map ShareNumber ImmutableShare -> [ShareNumber]
forall k a. Map k a -> [k]
Map.keys (Map ShareNumber ImmutableShare -> [ShareNumber])
-> (Bucket -> Map ShareNumber ImmutableShare)
-> Bucket
-> [ShareNumber]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bucket -> Map ShareNumber ImmutableShare
bucketShares (Bucket -> [ShareNumber]) -> Bucket -> [ShareNumber]
forall a b. (a -> b) -> a -> b
$ Bucket
bucket

-- Attempt to allocate space at a certain storage index for some numbered
-- shares.  The space is only allocated if there is not yet any data for those
-- share numbers at that storage index.  The modified backend and a report of
-- the allocation done are returned.
allocate ::
    -- | The storage index at which to attempt the allocation.
    StorageIndex ->
    -- | The share numbers to attempt to allocate.
    [ShareNumber] ->
    -- | A shared secret authorizing write attempts to the allocated shares.
    UploadSecret ->
    -- | The size in bytes to allocate for each share.
    Size ->
    -- | The backend in which to do the allocation.
    MemoryBackend ->
    -- | The modified backend and the results of the allocation.
    (MemoryBackend, AllocationResult)
allocate :: String
-> [ShareNumber]
-> UploadSecret
-> Size
-> MemoryBackend
-> (MemoryBackend, AllocationResult)
allocate String
storageIndex [ShareNumber]
shareNumbers UploadSecret
uploadSecret Size
size backend :: MemoryBackend
backend@MemoryBackend{Map String Bucket
memoryBackendBuckets :: Map String Bucket
memoryBackendBuckets :: MemoryBackend -> Map String Bucket
memoryBackendBuckets}
    | Size -> (Bucket -> Size) -> Maybe Bucket -> Size
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Size
size Bucket -> Size
bucketSize Maybe Bucket
existing Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
/= Size
size = WriteImmutableError -> (MemoryBackend, AllocationResult)
forall a e. Exception e => e -> a
throw WriteImmutableError
ShareSizeMismatch
    | Bool
otherwise =
        ( MemoryBackend
backend{memoryBackendBuckets :: Map String Bucket
memoryBackendBuckets = Map String Bucket
updated}
        , AllocationResult
result
        )
  where
    existing :: Maybe Bucket
existing = String -> Map String Bucket -> Maybe Bucket
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex Map String Bucket
memoryBackendBuckets
    updated :: Map String Bucket
updated = (Bucket -> Bucket -> Bucket)
-> String -> Bucket -> Map String Bucket -> Map String Bucket
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Bucket -> Bucket -> Bucket
mergeBuckets String
storageIndex Bucket
newBucket Map String Bucket
memoryBackendBuckets

    alreadyHave :: [ShareNumber]
alreadyHave = [ShareNumber]
-> (Bucket -> [ShareNumber]) -> Maybe Bucket -> [ShareNumber]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Map ShareNumber ImmutableShare -> [ShareNumber]
forall k a. Map k a -> [k]
Map.keys (Map ShareNumber ImmutableShare -> [ShareNumber])
-> (Bucket -> Map ShareNumber ImmutableShare)
-> Bucket
-> [ShareNumber]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bucket -> Map ShareNumber ImmutableShare
bucketShares) Maybe Bucket
existing
    allocated :: [ShareNumber]
allocated = (ShareNumber -> Bool) -> [ShareNumber] -> [ShareNumber]
forall a. (a -> Bool) -> [a] -> [a]
filter (ShareNumber -> [ShareNumber] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ShareNumber]
alreadyHave) [ShareNumber]
shareNumbers
    result :: AllocationResult
result = [ShareNumber] -> [ShareNumber] -> AllocationResult
AllocationResult [ShareNumber]
alreadyHave [ShareNumber]
allocated

    -- Merge two buckets given precedence to the right-hand bucket for overlap.
    mergeBuckets :: Bucket -> Bucket -> Bucket
mergeBuckets (Bucket Size
_ Map ShareNumber ImmutableShare
newShares) (Bucket Size
_ Map ShareNumber ImmutableShare
oldShares) = Size -> Map ShareNumber ImmutableShare -> Bucket
Bucket Size
size (Map ShareNumber ImmutableShare
newShares Map ShareNumber ImmutableShare
-> Map ShareNumber ImmutableShare -> Map ShareNumber ImmutableShare
forall a. Semigroup a => a -> a -> a
<> Map ShareNumber ImmutableShare
oldShares)

    -- The bucket we would allocate if there were no relevant existing state.
    newBucket :: Bucket
newBucket = Size -> Map ShareNumber ImmutableShare -> Bucket
Bucket Size
size ([(ShareNumber, ImmutableShare)] -> Map ShareNumber ImmutableShare
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([ShareNumber]
-> [ImmutableShare] -> [(ShareNumber, ImmutableShare)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ShareNumber]
shareNumbers (ImmutableShare -> [ImmutableShare]
forall a. a -> [a]
repeat ImmutableShare
newUpload)))
    newUpload :: ImmutableShare
newUpload = UploadSecret -> ShareData -> ImmutableShare
Uploading UploadSecret
uploadSecret ShareData
""

abort ::
    StorageIndex ->
    ShareNumber ->
    UploadSecret ->
    MemoryBackend ->
    (MemoryBackend, ())
abort :: String
-> ShareNumber
-> UploadSecret
-> MemoryBackend
-> (MemoryBackend, ())
abort String
storageIndex ShareNumber
shareNumber (UploadSecret ShareData
abortSecret) b :: MemoryBackend
b@MemoryBackend{Map String Bucket
memoryBackendBuckets :: Map String Bucket
memoryBackendBuckets :: MemoryBackend -> Map String Bucket
memoryBackendBuckets} = (MemoryBackend
b{memoryBackendBuckets :: Map String Bucket
memoryBackendBuckets = Map String Bucket -> Map String Bucket
updated Map String Bucket
memoryBackendBuckets}, ())
  where
    updated :: Map.Map StorageIndex Bucket -> Map.Map StorageIndex Bucket
    updated :: Map String Bucket -> Map String Bucket
updated = (Bucket -> Bucket)
-> String -> Map String Bucket -> Map String Bucket
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Bucket -> Bucket
abortIt String
storageIndex

    abortIt :: Bucket -> Bucket
    abortIt :: Bucket -> Bucket
abortIt bucket :: Bucket
bucket@Bucket{Map ShareNumber ImmutableShare
bucketShares :: Map ShareNumber ImmutableShare
bucketShares :: Bucket -> Map ShareNumber ImmutableShare
bucketShares} = Bucket
bucket{bucketShares :: Map ShareNumber ImmutableShare
bucketShares = (ImmutableShare -> Maybe ImmutableShare)
-> ShareNumber
-> Map ShareNumber ImmutableShare
-> Map ShareNumber ImmutableShare
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update ImmutableShare -> Maybe ImmutableShare
abortIt' ShareNumber
shareNumber Map ShareNumber ImmutableShare
bucketShares}

    abortIt' :: ImmutableShare -> Maybe ImmutableShare
    abortIt' :: ImmutableShare -> Maybe ImmutableShare
abortIt' (Uploading (UploadSecret ShareData
existingSecret) ShareData
_) = if ShareData -> ShareData -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
constEq ShareData
existingSecret ShareData
abortSecret then Maybe ImmutableShare
forall a. Maybe a
Nothing else WriteImmutableError -> Maybe ImmutableShare
forall a e. Exception e => e -> a
throw WriteImmutableError
IncorrectUploadSecret
    abortIt' ImmutableShare
_ = WriteImmutableError -> Maybe ImmutableShare
forall a e. Exception e => e -> a
throw WriteImmutableError
ImmutableShareAlreadyWritten

writeImm ::
    StorageIndex ->
    ShareNumber ->
    UploadSecret ->
    B.ByteString ->
    MemoryBackend ->
    (MemoryBackend, ())
writeImm :: String
-> ShareNumber
-> UploadSecret
-> ShareData
-> MemoryBackend
-> (MemoryBackend, ())
writeImm String
storageIndex ShareNumber
shareNum (UploadSecret ShareData
uploadSecret) ShareData
newData b :: MemoryBackend
b@MemoryBackend{Map String Bucket
memoryBackendBuckets :: Map String Bucket
memoryBackendBuckets :: MemoryBackend -> Map String Bucket
memoryBackendBuckets}
    | Maybe ImmutableShare -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ImmutableShare
share = WriteImmutableError -> (MemoryBackend, ())
forall a e. Exception e => e -> a
throw WriteImmutableError
ShareNotAllocated
    | Bool
otherwise = (MemoryBackend
b{memoryBackendBuckets :: Map String Bucket
memoryBackendBuckets = Map String Bucket
updated}, ())
  where
    bucket :: Maybe Bucket
bucket = String -> Map String Bucket -> Maybe Bucket
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex Map String Bucket
memoryBackendBuckets
    share :: Maybe ImmutableShare
share = Maybe Bucket
bucket Maybe Bucket
-> (Bucket -> Maybe ImmutableShare) -> Maybe ImmutableShare
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ShareNumber
-> Map ShareNumber ImmutableShare -> Maybe ImmutableShare
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ShareNumber
shareNum (Map ShareNumber ImmutableShare -> Maybe ImmutableShare)
-> (Bucket -> Map ShareNumber ImmutableShare)
-> Bucket
-> Maybe ImmutableShare
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bucket -> Map ShareNumber ImmutableShare
bucketShares
    size :: Maybe Size
size = Bucket -> Size
bucketSize (Bucket -> Size) -> Maybe Bucket -> Maybe Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bucket
bucket
    updated :: Map String Bucket
updated = (Bucket -> Bucket)
-> String -> Map String Bucket -> Map String Bucket
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Bucket
bkt -> Bucket
bkt{bucketShares :: Map ShareNumber ImmutableShare
bucketShares = (ImmutableShare -> ImmutableShare)
-> ShareNumber
-> Map ShareNumber ImmutableShare
-> Map ShareNumber ImmutableShare
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ImmutableShare -> ImmutableShare
writeToShare ShareNumber
shareNum (Bucket -> Map ShareNumber ImmutableShare
bucketShares Bucket
bkt)}) String
storageIndex Map String Bucket
memoryBackendBuckets

    writeToShare :: ImmutableShare -> ImmutableShare
    writeToShare :: ImmutableShare -> ImmutableShare
writeToShare (Complete ShareData
_) = WriteImmutableError -> ImmutableShare
forall a e. Exception e => e -> a
throw WriteImmutableError
ImmutableShareAlreadyWritten
    writeToShare (Uploading (UploadSecret ShareData
existingSecret) ShareData
existingData)
        | Bool
authorized =
            (if Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (ShareData -> ShareData -> Size -> Bool
forall a. Integral a => ShareData -> ShareData -> a -> Bool
complete ShareData
existingData ShareData
newData (Size -> Bool) -> Maybe Size -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Size
size) then ShareData -> ImmutableShare
Complete else UploadSecret -> ShareData -> ImmutableShare
Uploading (ShareData -> UploadSecret
UploadSecret ShareData
existingSecret)) (ShareData
existingData ShareData -> ShareData -> ShareData
forall a. Semigroup a => a -> a -> a
<> ShareData
newData)
        | Bool
otherwise = WriteImmutableError -> ImmutableShare
forall a e. Exception e => e -> a
throw WriteImmutableError
IncorrectUploadSecret
      where
        authorized :: Bool
authorized = ShareData -> ShareData -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
constEq ShareData
existingSecret ShareData
uploadSecret

    complete :: ShareData -> ShareData -> a -> Bool
complete ShareData
x ShareData
y = (ShareData -> Int
B.length ShareData
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ShareData -> Int
B.length ShareData
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool) -> (a -> Int) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Show MemoryBackend where
    show :: MemoryBackend -> String
show MemoryBackend
_ = String
"<MemoryBackend>"

instance Backend (IORef MemoryBackend) where
    version :: IORef MemoryBackend -> IO Version
version IORef MemoryBackend
backend = do
        Size
totalSize <- IORef MemoryBackend -> IO MemoryBackend
forall a. IORef a -> IO a
readIORef IORef MemoryBackend
backend IO MemoryBackend -> (MemoryBackend -> IO Size) -> IO Size
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MemoryBackend -> IO Size
totalShareSize
        Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return
            Version :: Version1Parameters -> ShareData -> Version
Version
                { applicationVersion :: ShareData
applicationVersion = ShareData
"(memory)"
                , parameters :: Version1Parameters
parameters =
                    Version1Parameters :: Size -> Size -> Size -> Version1Parameters
Version1Parameters
                        { maximumImmutableShareSize :: Size
maximumImmutableShareSize = Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
64
                        , maximumMutableShareSize :: Size
maximumMutableShareSize = Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
64
                        , availableSpace :: Size
availableSpace = (Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1024 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
1024) Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
totalSize
                        }
                }

    getMutableShareNumbers :: IORef MemoryBackend -> StorageIndex -> IO (CBORSet ShareNumber)
    getMutableShareNumbers :: IORef MemoryBackend -> String -> IO (CBORSet ShareNumber)
getMutableShareNumbers IORef MemoryBackend
backend String
storageIndex = do
        Maybe (Map ShareNumber [WriteVector])
sharemap <- (SecretProtected (Map ShareNumber [WriteVector])
 -> Map ShareNumber [WriteVector])
-> Maybe (SecretProtected (Map ShareNumber [WriteVector]))
-> Maybe (Map ShareNumber [WriteVector])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SecretProtected (Map ShareNumber [WriteVector])
-> Map ShareNumber [WriteVector]
forall a. SecretProtected a -> a
readProtected (Maybe (SecretProtected (Map ShareNumber [WriteVector]))
 -> Maybe (Map ShareNumber [WriteVector]))
-> (MemoryBackend
    -> Maybe (SecretProtected (Map ShareNumber [WriteVector])))
-> MemoryBackend
-> Maybe (Map ShareNumber [WriteVector])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> MutableShareStorage
-> Maybe (SecretProtected (Map ShareNumber [WriteVector]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex (MutableShareStorage
 -> Maybe (SecretProtected (Map ShareNumber [WriteVector])))
-> (MemoryBackend -> MutableShareStorage)
-> MemoryBackend
-> Maybe (SecretProtected (Map ShareNumber [WriteVector]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBackend -> MutableShareStorage
mutableShares (MemoryBackend -> Maybe (Map ShareNumber [WriteVector]))
-> IO MemoryBackend -> IO (Maybe (Map ShareNumber [WriteVector]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MemoryBackend -> IO MemoryBackend
forall a. IORef a -> IO a
readIORef IORef MemoryBackend
backend
        CBORSet ShareNumber -> IO (CBORSet ShareNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return
            (CBORSet ShareNumber -> IO (CBORSet ShareNumber))
-> (Maybe (Map ShareNumber [WriteVector]) -> CBORSet ShareNumber)
-> Maybe (Map ShareNumber [WriteVector])
-> IO (CBORSet ShareNumber)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ShareNumber -> CBORSet ShareNumber
forall a. Set a -> CBORSet a
CBORSet
            (Set ShareNumber -> CBORSet ShareNumber)
-> (Maybe (Map ShareNumber [WriteVector]) -> Set ShareNumber)
-> Maybe (Map ShareNumber [WriteVector])
-> CBORSet ShareNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShareNumber] -> Set ShareNumber
forall a. Ord a => [a] -> Set a
Set.fromList
            ([ShareNumber] -> Set ShareNumber)
-> (Maybe (Map ShareNumber [WriteVector]) -> [ShareNumber])
-> Maybe (Map ShareNumber [WriteVector])
-> Set ShareNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShareNumber]
-> (Map ShareNumber [WriteVector] -> [ShareNumber])
-> Maybe (Map ShareNumber [WriteVector])
-> [ShareNumber]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Map ShareNumber [WriteVector] -> [ShareNumber]
forall k a. Map k a -> [k]
Map.keys
            (Maybe (Map ShareNumber [WriteVector]) -> IO (CBORSet ShareNumber))
-> Maybe (Map ShareNumber [WriteVector])
-> IO (CBORSet ShareNumber)
forall a b. (a -> b) -> a -> b
$ Maybe (Map ShareNumber [WriteVector])
sharemap

    readvAndTestvAndWritev :: IORef MemoryBackend -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO ReadTestWriteResult
    readvAndTestvAndWritev :: IORef MemoryBackend
-> String
-> WriteEnablerSecret
-> ReadTestWriteVectors
-> IO ReadTestWriteResult
readvAndTestvAndWritev
        IORef MemoryBackend
backend
        String
storageIndex
        WriteEnablerSecret
secret
        (ReadTestWriteVectors Map ShareNumber TestWriteVectors
testWritev [ReadVector]
readv) = do
            -- TODO implement testv parts.

            (CBORSet Set ShareNumber
allShareNums) <- IORef MemoryBackend -> String -> IO (CBORSet ShareNumber)
forall b. Backend b => b -> String -> IO (CBORSet ShareNumber)
getMutableShareNumbers IORef MemoryBackend
backend String
storageIndex
            let queryRange :: QueryRange
queryRange = [ReadVector] -> QueryRange
readvToQueryRange [ReadVector]
readv

            [(ShareNumber, [ShareData])]
readData <- (ShareNumber -> IO (ShareNumber, [ShareData]))
-> [ShareNumber] -> IO [(ShareNumber, [ShareData])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ShareNumber
shareNum -> (ShareNumber
shareNum,) ([ShareData] -> (ShareNumber, [ShareData]))
-> IO [ShareData] -> IO (ShareNumber, [ShareData])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MemoryBackend
-> String -> ShareNumber -> QueryRange -> IO [ShareData]
readMutableShare' IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNum QueryRange
queryRange) (Set ShareNumber -> [ShareNumber]
forall a. Set a -> [a]
Set.toList Set ShareNumber
allShareNums)
            WriteResult
outcome <- IORef MemoryBackend
-> (MemoryBackend -> (MemoryBackend, WriteResult))
-> IO WriteResult
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef MemoryBackend
backend MemoryBackend -> (MemoryBackend, WriteResult)
tryWrite
            case WriteResult
outcome of
                WriteResult
TestSuccess ->
                    ReadTestWriteResult -> IO ReadTestWriteResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                        ReadTestWriteResult :: Bool -> ReadResult -> ReadTestWriteResult
ReadTestWriteResult
                            { readData :: ReadResult
readData = [(ShareNumber, [ShareData])] -> ReadResult
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ShareNumber, [ShareData])]
readData
                            , success :: Bool
success = Bool
True
                            }
                WriteResult
TestFail ->
                    ReadTestWriteResult -> IO ReadTestWriteResult
forall (m :: * -> *) a. Monad m => a -> m a
return
                        ReadTestWriteResult :: Bool -> ReadResult -> ReadTestWriteResult
ReadTestWriteResult
                            { readData :: ReadResult
readData = [(ShareNumber, [ShareData])] -> ReadResult
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ShareNumber, [ShareData])]
readData
                            , success :: Bool
success = Bool
False
                            }
                WriteResult
SecretMismatch ->
                    WriteImmutableError -> IO ReadTestWriteResult
forall e a. Exception e => e -> IO a
throwIO WriteImmutableError
IncorrectWriteEnablerSecret
          where
            readvToQueryRange :: [ReadVector] -> QueryRange
            --            readvToQueryRange [] = Nothing
            readvToQueryRange :: [ReadVector] -> QueryRange
readvToQueryRange [ReadVector]
rv = [ByteRange] -> QueryRange
forall a. a -> Maybe a
Just ([ReadVector] -> [ByteRange]
go [ReadVector]
rv)
              where
                go :: [ReadVector] -> [ByteRange]
go [] = []
                go (ReadVector
r : [ReadVector]
rs) = Size -> Size -> ByteRange
ByteRangeFromTo Size
off Size
end ByteRange -> [ByteRange] -> [ByteRange]
forall a. a -> [a] -> [a]
: [ReadVector] -> [ByteRange]
go [ReadVector]
rs
                  where
                    off :: Size
off = ReadVector -> Size
offset ReadVector
r
                    end :: Size
end = Size
off Size -> Size -> Size
forall a. Num a => a -> a -> a
+ ReadVector -> Size
readSize ReadVector
r Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1

            tryWrite :: MemoryBackend -> (MemoryBackend, WriteResult)
tryWrite m :: MemoryBackend
m@MemoryBackend{MutableShareStorage
mutableShares :: MutableShareStorage
mutableShares :: MemoryBackend -> MutableShareStorage
mutableShares} =
                case String
-> WriteEnablerSecret
-> MutableShareStorage
-> Map ShareNumber [WriteVector]
-> Maybe MutableShareStorage
addShares String
storageIndex WriteEnablerSecret
secret MutableShareStorage
mutableShares ((TestWriteVectors -> [WriteVector])
-> Map ShareNumber TestWriteVectors
-> Map ShareNumber [WriteVector]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map TestWriteVectors -> [WriteVector]
write Map ShareNumber TestWriteVectors
testWritev) of
                    Maybe MutableShareStorage
Nothing -> (MemoryBackend
m, WriteResult
SecretMismatch)
                    Just MutableShareStorage
newShares -> (MemoryBackend
m{mutableShares :: MutableShareStorage
mutableShares = MutableShareStorage
newShares}, WriteResult
TestSuccess)

    readMutableShare :: IORef MemoryBackend
-> String -> ShareNumber -> QueryRange -> IO ShareData
readMutableShare IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNum QueryRange
queryRange =
        [ShareData] -> ShareData
B.concat ([ShareData] -> ShareData) -> IO [ShareData] -> IO ShareData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MemoryBackend
-> String -> ShareNumber -> QueryRange -> IO [ShareData]
readMutableShare' IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNum QueryRange
queryRange

    createImmutableStorageIndex :: IORef MemoryBackend
-> String
-> Maybe [LeaseSecret]
-> AllocateBuckets
-> IO AllocationResult
createImmutableStorageIndex IORef MemoryBackend
backend String
storageIndex Maybe [LeaseSecret]
secrets (AllocateBuckets [ShareNumber]
shareNums Size
size) =
        Maybe [LeaseSecret]
-> (UploadSecret -> IO AllocationResult) -> IO AllocationResult
forall a. Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
secrets ((UploadSecret -> IO AllocationResult) -> IO AllocationResult)
-> (UploadSecret -> IO AllocationResult) -> IO AllocationResult
forall a b. (a -> b) -> a -> b
$ \UploadSecret
secret ->
            IORef MemoryBackend
-> (MemoryBackend -> (MemoryBackend, AllocationResult))
-> IO AllocationResult
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef MemoryBackend
backend (String
-> [ShareNumber]
-> UploadSecret
-> Size
-> MemoryBackend
-> (MemoryBackend, AllocationResult)
allocate String
storageIndex [ShareNumber]
shareNums UploadSecret
secret Size
size)

    abortImmutableUpload :: IORef MemoryBackend
-> String -> ShareNumber -> Maybe [LeaseSecret] -> IO ()
abortImmutableUpload IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNumber Maybe [LeaseSecret]
secrets =
        Maybe [LeaseSecret] -> (UploadSecret -> IO ()) -> IO ()
forall a. Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
secrets ((UploadSecret -> IO ()) -> IO ())
-> (UploadSecret -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UploadSecret
secret ->
            IORef MemoryBackend
-> (MemoryBackend -> (MemoryBackend, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef MemoryBackend
backend (String
-> ShareNumber
-> UploadSecret
-> MemoryBackend
-> (MemoryBackend, ())
abort String
storageIndex ShareNumber
shareNumber UploadSecret
secret)

    writeImmutableShare :: IORef MemoryBackend
-> String
-> ShareNumber
-> Maybe [LeaseSecret]
-> ShareData
-> QueryRange
-> IO ()
writeImmutableShare IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNumber Maybe [LeaseSecret]
secrets ShareData
shareData QueryRange
Nothing = do
        Maybe [LeaseSecret] -> (UploadSecret -> IO ()) -> IO ()
forall a. Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
secrets ((UploadSecret -> IO ()) -> IO ())
-> (UploadSecret -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UploadSecret
secret ->
            IORef MemoryBackend
-> (MemoryBackend -> (MemoryBackend, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef MemoryBackend
backend (String
-> ShareNumber
-> UploadSecret
-> ShareData
-> MemoryBackend
-> (MemoryBackend, ())
writeImm String
storageIndex ShareNumber
shareNumber UploadSecret
secret ShareData
shareData)
    writeImmutableShare IORef MemoryBackend
_ String
_ ShareNumber
_ Maybe [LeaseSecret]
_ ShareData
_ QueryRange
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"writeImmutableShare got bad input"

    adviseCorruptImmutableShare :: IORef MemoryBackend
-> String -> ShareNumber -> CorruptionDetails -> IO ()
adviseCorruptImmutableShare IORef MemoryBackend
_backend String
_ ShareNumber
_ CorruptionDetails
_ =
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. Monoid a => a
mempty

    getImmutableShareNumbers :: IORef MemoryBackend -> String -> IO (CBORSet ShareNumber)
getImmutableShareNumbers IORef MemoryBackend
backend String
storageIndex = String -> MemoryBackend -> CBORSet ShareNumber
getShareNumbers String
storageIndex (MemoryBackend -> CBORSet ShareNumber)
-> IO MemoryBackend -> IO (CBORSet ShareNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MemoryBackend -> IO MemoryBackend
forall a. IORef a -> IO a
readIORef IORef MemoryBackend
backend

    readImmutableShare :: IORef MemoryBackend
-> String -> ShareNumber -> QueryRange -> IO ShareData
readImmutableShare IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNum QueryRange
_qr = do
        Map String Bucket
buckets <- MemoryBackend -> Map String Bucket
memoryBackendBuckets (MemoryBackend -> Map String Bucket)
-> IO MemoryBackend -> IO (Map String Bucket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MemoryBackend -> IO MemoryBackend
forall a. IORef a -> IO a
readIORef IORef MemoryBackend
backend
        case String -> Map String Bucket -> Maybe Bucket
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex Map String Bucket
buckets of
            Maybe Bucket
Nothing -> ShareData -> IO ShareData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShareData
forall a. Monoid a => a
mempty
            Just Bucket
bucket -> case ShareNumber
-> Map ShareNumber ImmutableShare -> Maybe ImmutableShare
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ShareNumber
shareNum (Bucket -> Map ShareNumber ImmutableShare
bucketShares Bucket
bucket) of
                Just (Complete ShareData
shareData) -> ShareData -> IO ShareData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShareData
shareData
                Maybe ImmutableShare
_ -> ShareData -> IO ShareData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShareData
forall a. Monoid a => a
mempty

totalShareSize :: MemoryBackend -> IO Size
totalShareSize :: MemoryBackend -> IO Size
totalShareSize MemoryBackend
backend = do
    let imm :: Map String Bucket
imm = MemoryBackend -> Map String Bucket
memoryBackendBuckets MemoryBackend
backend
        mut :: MutableShareStorage
mut = MemoryBackend -> MutableShareStorage
mutableShares MemoryBackend
backend
    let immSize :: Size
immSize = Map String Size -> Size
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Map String Size -> Size) -> Map String Size -> Size
forall a b. (a -> b) -> a -> b
$ (Bucket -> Size) -> Map String Bucket -> Map String Size
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Bucket -> Size
bucketTotalSize Map String Bucket
imm
    let mutSize :: Int
mutSize = Map String Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Map String Int -> Int) -> Map String Int -> Int
forall a b. (a -> b) -> a -> b
$ (SecretProtected (Map ShareNumber [WriteVector]) -> Int)
-> MutableShareStorage -> Map String Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Map ShareNumber [WriteVector] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map ShareNumber [WriteVector] -> Int)
-> (SecretProtected (Map ShareNumber [WriteVector])
    -> Map ShareNumber [WriteVector])
-> SecretProtected (Map ShareNumber [WriteVector])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretProtected (Map ShareNumber [WriteVector])
-> Map ShareNumber [WriteVector]
forall a. SecretProtected a -> a
readProtected) MutableShareStorage
mut
    Size -> IO Size
forall (m :: * -> *) a. Monad m => a -> m a
return (Size -> IO Size) -> Size -> IO Size
forall a b. (a -> b) -> a -> b
$ Size -> Size
forall a. Integral a => a -> Size
toInteger (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
immSize Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mutSize

bucketTotalSize :: Bucket -> Size
bucketTotalSize :: Bucket -> Size
bucketTotalSize Bucket{Size
bucketSize :: Size
bucketSize :: Bucket -> Size
bucketSize, Map ShareNumber ImmutableShare
bucketShares :: Map ShareNumber ImmutableShare
bucketShares :: Bucket -> Map ShareNumber ImmutableShare
bucketShares} = Size
bucketSize Size -> Size -> Size
forall a. Num a => a -> a -> a
* Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map ShareNumber ImmutableShare -> Int
forall k a. Map k a -> Int
Map.size Map ShareNumber ImmutableShare
bucketShares)

addShare :: StorageIndex -> WriteEnablerSecret -> ShareNumber -> [WriteVector] -> MutableShareStorage -> MutableShareStorage
addShare :: String
-> WriteEnablerSecret
-> ShareNumber
-> [WriteVector]
-> MutableShareStorage
-> MutableShareStorage
addShare String
storageIndex WriteEnablerSecret
secret ShareNumber
shareNum [WriteVector]
writev =
    (SecretProtected (Map ShareNumber [WriteVector])
 -> SecretProtected (Map ShareNumber [WriteVector])
 -> SecretProtected (Map ShareNumber [WriteVector]))
-> String
-> SecretProtected (Map ShareNumber [WriteVector])
-> MutableShareStorage
-> MutableShareStorage
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((Map ShareNumber [WriteVector]
 -> Map ShareNumber [WriteVector] -> Map ShareNumber [WriteVector])
-> SecretProtected (Map ShareNumber [WriteVector])
-> SecretProtected (Map ShareNumber [WriteVector])
-> SecretProtected (Map ShareNumber [WriteVector])
forall a.
(a -> a -> a)
-> SecretProtected a -> SecretProtected a -> SecretProtected a
liftProtected2 Map ShareNumber [WriteVector]
-> Map ShareNumber [WriteVector] -> Map ShareNumber [WriteVector]
f) String
storageIndex SecretProtected (Map ShareNumber [WriteVector])
newShare
  where
    f :: Map.Map ShareNumber [WriteVector] -> Map.Map ShareNumber [WriteVector] -> Map.Map ShareNumber [WriteVector]
    f :: Map ShareNumber [WriteVector]
-> Map ShareNumber [WriteVector] -> Map ShareNumber [WriteVector]
f = SimpleWhenMissing ShareNumber [WriteVector] [WriteVector]
-> SimpleWhenMissing ShareNumber [WriteVector] [WriteVector]
-> SimpleWhenMatched
     ShareNumber [WriteVector] [WriteVector] [WriteVector]
-> Map ShareNumber [WriteVector]
-> Map ShareNumber [WriteVector]
-> Map ShareNumber [WriteVector]
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge SimpleWhenMissing ShareNumber [WriteVector] [WriteVector]
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
preserveMissing SimpleWhenMissing ShareNumber [WriteVector] [WriteVector]
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
preserveMissing ((ShareNumber -> [WriteVector] -> [WriteVector] -> [WriteVector])
-> SimpleWhenMatched
     ShareNumber [WriteVector] [WriteVector] [WriteVector]
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
zipWithMatched (([WriteVector] -> [WriteVector] -> [WriteVector])
-> ShareNumber -> [WriteVector] -> [WriteVector] -> [WriteVector]
forall a b. a -> b -> a
const [WriteVector] -> [WriteVector] -> [WriteVector]
forall a. Semigroup a => a -> a -> a
(<>)))

    newShare :: SecretProtected (Map ShareNumber [WriteVector])
newShare = WriteEnablerSecret
-> Map ShareNumber [WriteVector]
-> SecretProtected (Map ShareNumber [WriteVector])
forall a. WriteEnablerSecret -> a -> SecretProtected a
SecretProtected WriteEnablerSecret
secret (ShareNumber -> [WriteVector] -> Map ShareNumber [WriteVector]
forall k a. k -> a -> Map k a
Map.singleton ShareNumber
shareNum [WriteVector]
writev)

addShares :: StorageIndex -> WriteEnablerSecret -> MutableShareStorage -> Map.Map ShareNumber [WriteVector] -> Maybe MutableShareStorage
addShares :: String
-> WriteEnablerSecret
-> MutableShareStorage
-> Map ShareNumber [WriteVector]
-> Maybe MutableShareStorage
addShares String
storageIndex WriteEnablerSecret
secret MutableShareStorage
existing Map ShareNumber [WriteVector]
updates
    | Maybe WriteEnablerSecret -> Bool
forall a. Maybe a -> Bool
isNothing Maybe WriteEnablerSecret
existingSecret = MutableShareStorage -> Maybe MutableShareStorage
forall a. a -> Maybe a
Just MutableShareStorage
go
    | Maybe WriteEnablerSecret
existingSecret Maybe WriteEnablerSecret -> Maybe WriteEnablerSecret -> Bool
forall a. Eq a => a -> a -> Bool
== WriteEnablerSecret -> Maybe WriteEnablerSecret
forall a. a -> Maybe a
Just WriteEnablerSecret
secret = MutableShareStorage -> Maybe MutableShareStorage
forall a. a -> Maybe a
Just MutableShareStorage
go
    | Bool
otherwise = Maybe MutableShareStorage
forall a. Maybe a
Nothing
  where
    go :: MutableShareStorage
go = (ShareNumber
 -> [WriteVector] -> MutableShareStorage -> MutableShareStorage)
-> MutableShareStorage
-> Map ShareNumber [WriteVector]
-> MutableShareStorage
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (String
-> WriteEnablerSecret
-> ShareNumber
-> [WriteVector]
-> MutableShareStorage
-> MutableShareStorage
addShare String
storageIndex WriteEnablerSecret
secret) MutableShareStorage
existing Map ShareNumber [WriteVector]
updates

    existingSecret :: Maybe WriteEnablerSecret
existingSecret = SecretProtected (Map ShareNumber [WriteVector])
-> WriteEnablerSecret
forall a. SecretProtected a -> WriteEnablerSecret
readSecret (SecretProtected (Map ShareNumber [WriteVector])
 -> WriteEnablerSecret)
-> Maybe (SecretProtected (Map ShareNumber [WriteVector]))
-> Maybe WriteEnablerSecret
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> MutableShareStorage
-> Maybe (SecretProtected (Map ShareNumber [WriteVector]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex MutableShareStorage
existing

memoryBackend :: IO (IORef MemoryBackend)
memoryBackend :: IO (IORef MemoryBackend)
memoryBackend = do
    MemoryBackend -> IO (IORef MemoryBackend)
forall a. a -> IO (IORef a)
newIORef (MemoryBackend -> IO (IORef MemoryBackend))
-> MemoryBackend -> IO (IORef MemoryBackend)
forall a b. (a -> b) -> a -> b
$ Map String Bucket -> MutableShareStorage -> MemoryBackend
MemoryBackend Map String Bucket
forall a. Monoid a => a
mempty MutableShareStorage
forall a. Monoid a => a
mempty

readMutableShare' :: IORef MemoryBackend -> StorageIndex -> ShareNumber -> QueryRange -> IO [ShareData]
readMutableShare' :: IORef MemoryBackend
-> String -> ShareNumber -> QueryRange -> IO [ShareData]
readMutableShare' IORef MemoryBackend
backend String
storageIndex ShareNumber
shareNum QueryRange
queryRange = do
    MutableShareStorage
storage <- MemoryBackend -> MutableShareStorage
mutableShares (MemoryBackend -> MutableShareStorage)
-> IO MemoryBackend -> IO MutableShareStorage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MemoryBackend -> IO MemoryBackend
forall a. IORef a -> IO a
readIORef IORef MemoryBackend
backend
    [ShareData] -> IO [ShareData]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ShareData] -> IO [ShareData]) -> [ShareData] -> IO [ShareData]
forall a b. (a -> b) -> a -> b
$ ReadVector -> MutableShareStorage -> ShareData
doOneRead (ReadVector -> MutableShareStorage -> ShareData)
-> [ReadVector] -> [MutableShareStorage -> ShareData]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableShareStorage -> [ReadVector]
rv MutableShareStorage
storage [MutableShareStorage -> ShareData]
-> [MutableShareStorage] -> [ShareData]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MutableShareStorage -> [MutableShareStorage]
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableShareStorage
storage
  where
    rv :: MutableShareStorage -> [ReadVector]
    rv :: MutableShareStorage -> [ReadVector]
rv MutableShareStorage
storage = MutableShareStorage -> QueryRange -> [ReadVector]
queryRangeToReadVector MutableShareStorage
storage QueryRange
queryRange

    getShareData :: MutableShareStorage -> Maybe [WriteVector]
getShareData MutableShareStorage
storage =
        String
-> MutableShareStorage
-> Maybe (SecretProtected (Map ShareNumber [WriteVector]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
storageIndex MutableShareStorage
storage Maybe (SecretProtected (Map ShareNumber [WriteVector]))
-> (SecretProtected (Map ShareNumber [WriteVector])
    -> Maybe [WriteVector])
-> Maybe [WriteVector]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ShareNumber -> Map ShareNumber [WriteVector] -> Maybe [WriteVector]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ShareNumber
shareNum (Map ShareNumber [WriteVector] -> Maybe [WriteVector])
-> (SecretProtected (Map ShareNumber [WriteVector])
    -> Map ShareNumber [WriteVector])
-> SecretProtected (Map ShareNumber [WriteVector])
-> Maybe [WriteVector]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretProtected (Map ShareNumber [WriteVector])
-> Map ShareNumber [WriteVector]
forall a. SecretProtected a -> a
readProtected

    doOneRead :: ReadVector -> MutableShareStorage -> ShareData
    doOneRead :: ReadVector -> MutableShareStorage -> ShareData
doOneRead ReadVector
readv MutableShareStorage
storage =
        ShareData
-> ([WriteVector] -> ShareData) -> Maybe [WriteVector] -> ShareData
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShareData
"" (ReadVector -> [WriteVector] -> ShareData
readOneVector ReadVector
readv) (MutableShareStorage -> Maybe [WriteVector]
getShareData MutableShareStorage
storage)

    queryRangeToReadVector :: MutableShareStorage -> QueryRange -> [ReadVector]
    queryRangeToReadVector :: MutableShareStorage -> QueryRange -> [ReadVector]
queryRangeToReadVector MutableShareStorage
storage QueryRange
Nothing = [Size -> Size -> ReadVector
ReadVector Size
0 Size
size]
      where
        size :: Size
size = Size -> ([WriteVector] -> Size) -> Maybe [WriteVector] -> Size
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Size
0 [WriteVector] -> Size
shareDataSize (MutableShareStorage -> Maybe [WriteVector]
getShareData MutableShareStorage
storage)
    queryRangeToReadVector MutableShareStorage
storage (Just [ByteRange]
ranges) = ByteRange -> ReadVector
toReadVector (ByteRange -> ReadVector) -> [ByteRange] -> [ReadVector]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteRange]
ranges
      where
        toReadVector :: ByteRange -> ReadVector
toReadVector (ByteRangeFrom Size
start) = Size -> Size -> ReadVector
ReadVector Size
start Size
size
          where
            size :: Size
size = Size -> ([WriteVector] -> Size) -> Maybe [WriteVector] -> Size
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Size
0 [WriteVector] -> Size
shareDataSize (MutableShareStorage -> Maybe [WriteVector]
getShareData MutableShareStorage
storage)
        toReadVector (ByteRangeFromTo Size
start Size
end) = Size -> Size -> ReadVector
ReadVector Size
start (Size
end Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
start Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1)
        toReadVector (ByteRangeSuffix Size
len) = Size -> Size -> ReadVector
ReadVector (Size
size Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
len) Size
len
          where
            size :: Size
size = Size -> ([WriteVector] -> Size) -> Maybe [WriteVector] -> Size
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Size
0 [WriteVector] -> Size
shareDataSize (MutableShareStorage -> Maybe [WriteVector]
getShareData MutableShareStorage
storage)

    readOneVector :: ReadVector -> [WriteVector] -> ShareData
    readOneVector :: ReadVector -> [WriteVector] -> ShareData
readOneVector ReadVector{Size
offset :: Size
offset :: ReadVector -> Size
offset, Size
readSize :: Size
readSize :: ReadVector -> Size
readSize} [WriteVector]
wv =
        [Word8] -> ShareData
B.pack (Size -> Word8
extractBytes (Size -> Word8) -> [Size] -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Size]
positions)
      where
        positions :: [Size]
positions = [Size
offset .. (Size
offset Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
readSize Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)]

        extractBytes :: Integer -> Word8
        extractBytes :: Size -> Word8
extractBytes Size
p = Word8 -> Maybe Word8 -> Word8
forall a. a -> Maybe a -> a
fromMaybe Word8
0 ([WriteVector] -> Maybe Word8
go [WriteVector]
wv)
          where
            -- New writes are added to the end of the list so give the Last
            -- write precedence over others.
            go :: [WriteVector] -> Maybe Word8
go = Last Word8 -> Maybe Word8
forall a. Last a -> Maybe a
getLast (Last Word8 -> Maybe Word8)
-> ([WriteVector] -> Last Word8) -> [WriteVector] -> Maybe Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WriteVector -> Last Word8) -> [WriteVector] -> Last Word8
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Word8 -> Last Word8
forall a. Maybe a -> Last a
Last (Maybe Word8 -> Last Word8)
-> (WriteVector -> Maybe Word8) -> WriteVector -> Last Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> WriteVector -> Maybe Word8
byteFromShare Size
p)

        byteFromShare :: Integer -> WriteVector -> Maybe Word8
        byteFromShare :: Size -> WriteVector -> Maybe Word8
byteFromShare Size
p (WriteVector Size
off ShareData
bytes)
            | Size
p Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
>= Size
off Bool -> Bool -> Bool
&& Size
p Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Size
off Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ShareData -> Int
B.length ShareData
bytes) = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (ShareData -> Int -> Word8
B.index ShareData
bytes (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size -> Int) -> Size -> Int
forall a b. (a -> b) -> a -> b
$ Size
p Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
off))
            | Bool
otherwise = Maybe Word8
forall a. Maybe a
Nothing

-- | Internal type tracking the result of an attempted mutable write.
data WriteResult
    = -- | The test condition succeeded and the write was performed.
      TestSuccess
    | -- | The test condition failed and the write was not performed.
      TestFail
    | -- | The supplied secret was incorrect and the write was not performed.
      SecretMismatch