{-# LANGUAGE DataKinds #-}

module TahoeLAFS.Storage.Backend (
    Backend (..),
    WriteImmutableError (..),
    writeMutableShare,
    withUploadSecret,
) where

import Control.Exception (
    Exception,
    throw,
    throwIO,
 )

import Data.Map.Strict (
    fromList,
 )

import Network.HTTP.Types (
    ByteRanges,
 )
import TahoeLAFS.Storage.API (
    AllocateBuckets,
    AllocationResult,
    CBORSet (..),
    CorruptionDetails,
    LeaseSecret (..),
    QueryRange,
    ReadTestWriteResult (..),
    ReadTestWriteVectors (..),
    ShareData,
    ShareNumber,
    StorageIndex,
    TestWriteVectors (..),
    UploadSecret (..),
    Version,
    WriteEnablerSecret,
    WriteVector (..),
    isUploadSecret,
 )

data WriteImmutableError
    = MissingUploadSecret
    | ShareSizeMismatch
    | ImmutableShareAlreadyWritten
    | ShareNotAllocated
    | IncorrectUploadSecret
    | IncorrectWriteEnablerSecret
    deriving (Eq WriteImmutableError
Eq WriteImmutableError
-> (WriteImmutableError -> WriteImmutableError -> Ordering)
-> (WriteImmutableError -> WriteImmutableError -> Bool)
-> (WriteImmutableError -> WriteImmutableError -> Bool)
-> (WriteImmutableError -> WriteImmutableError -> Bool)
-> (WriteImmutableError -> WriteImmutableError -> Bool)
-> (WriteImmutableError
    -> WriteImmutableError -> WriteImmutableError)
-> (WriteImmutableError
    -> WriteImmutableError -> WriteImmutableError)
-> Ord WriteImmutableError
WriteImmutableError -> WriteImmutableError -> Bool
WriteImmutableError -> WriteImmutableError -> Ordering
WriteImmutableError -> WriteImmutableError -> WriteImmutableError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WriteImmutableError -> WriteImmutableError -> WriteImmutableError
$cmin :: WriteImmutableError -> WriteImmutableError -> WriteImmutableError
max :: WriteImmutableError -> WriteImmutableError -> WriteImmutableError
$cmax :: WriteImmutableError -> WriteImmutableError -> WriteImmutableError
>= :: WriteImmutableError -> WriteImmutableError -> Bool
$c>= :: WriteImmutableError -> WriteImmutableError -> Bool
> :: WriteImmutableError -> WriteImmutableError -> Bool
$c> :: WriteImmutableError -> WriteImmutableError -> Bool
<= :: WriteImmutableError -> WriteImmutableError -> Bool
$c<= :: WriteImmutableError -> WriteImmutableError -> Bool
< :: WriteImmutableError -> WriteImmutableError -> Bool
$c< :: WriteImmutableError -> WriteImmutableError -> Bool
compare :: WriteImmutableError -> WriteImmutableError -> Ordering
$ccompare :: WriteImmutableError -> WriteImmutableError -> Ordering
$cp1Ord :: Eq WriteImmutableError
Ord, WriteImmutableError -> WriteImmutableError -> Bool
(WriteImmutableError -> WriteImmutableError -> Bool)
-> (WriteImmutableError -> WriteImmutableError -> Bool)
-> Eq WriteImmutableError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteImmutableError -> WriteImmutableError -> Bool
$c/= :: WriteImmutableError -> WriteImmutableError -> Bool
== :: WriteImmutableError -> WriteImmutableError -> Bool
$c== :: WriteImmutableError -> WriteImmutableError -> Bool
Eq, Int -> WriteImmutableError -> ShowS
[WriteImmutableError] -> ShowS
WriteImmutableError -> String
(Int -> WriteImmutableError -> ShowS)
-> (WriteImmutableError -> String)
-> ([WriteImmutableError] -> ShowS)
-> Show WriteImmutableError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteImmutableError] -> ShowS
$cshowList :: [WriteImmutableError] -> ShowS
show :: WriteImmutableError -> String
$cshow :: WriteImmutableError -> String
showsPrec :: Int -> WriteImmutableError -> ShowS
$cshowsPrec :: Int -> WriteImmutableError -> ShowS
Show)
instance Exception WriteImmutableError

class Backend b where
    version :: b -> IO Version

    -- | Update the lease expiration time on the shares associated with the
    -- given storage index.
    renewLease :: b -> StorageIndex -> [LeaseSecret] -> IO ()

    createImmutableStorageIndex :: b -> StorageIndex -> Maybe [LeaseSecret] -> AllocateBuckets -> IO AllocationResult

    -- May throw ImmutableShareAlreadyWritten
    writeImmutableShare :: b -> StorageIndex -> ShareNumber -> Maybe [LeaseSecret] -> ShareData -> Maybe ByteRanges -> IO ()
    abortImmutableUpload :: b -> StorageIndex -> ShareNumber -> Maybe [LeaseSecret] -> IO ()
    adviseCorruptImmutableShare :: b -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()
    getImmutableShareNumbers :: b -> StorageIndex -> IO (CBORSet ShareNumber)
    readImmutableShare :: b -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData

    -- | Read some ranges of all shares held and/or, if test conditions are
    -- met, overwrite some ranges of some shares.
    readvAndTestvAndWritev ::
        b ->
        -- | The storage index at which to operate.
        StorageIndex ->
        -- | A shared secret which the backend can use to authorize the writes.
        WriteEnablerSecret ->
        -- | The reads, tests, and writes to perform.
        ReadTestWriteVectors ->
        IO ReadTestWriteResult

    readMutableShare :: b -> StorageIndex -> ShareNumber -> QueryRange -> IO ShareData
    getMutableShareNumbers :: b -> StorageIndex -> IO (CBORSet ShareNumber)
    adviseCorruptMutableShare :: b -> StorageIndex -> ShareNumber -> CorruptionDetails -> IO ()

writeMutableShare ::
    Backend b =>
    b ->
    StorageIndex ->
    ShareNumber ->
    WriteEnablerSecret ->
    ShareData ->
    Maybe ByteRanges ->
    IO ()
writeMutableShare :: b
-> String
-> ShareNumber
-> WriteEnablerSecret
-> ShareData
-> Maybe ByteRanges
-> IO ()
writeMutableShare b
b String
storageIndex ShareNumber
shareNumber WriteEnablerSecret
writeEnablerSecret ShareData
shareData Maybe ByteRanges
Nothing = do
    let testWriteVectors :: Map ShareNumber TestWriteVectors
testWriteVectors =
            [(ShareNumber, TestWriteVectors)]
-> Map ShareNumber TestWriteVectors
forall k a. Ord k => [(k, a)] -> Map k a
fromList
                [
                    ( ShareNumber
shareNumber
                    , TestWriteVectors :: [TestVector] -> [WriteVector] -> Maybe Integer -> TestWriteVectors
TestWriteVectors
                        { test :: [TestVector]
test = []
                        , write :: [WriteVector]
write =
                            [ WriteVector :: Integer -> ShareData -> WriteVector
WriteVector
                                { writeOffset :: Integer
writeOffset = Integer
0
                                , shareData :: ShareData
shareData = ShareData
shareData
                                }
                            ]
                        , newLength :: Maybe Integer
newLength = Maybe Integer
forall a. Maybe a
Nothing -- XXX expose this?
                        }
                    )
                ]
    let vectors :: ReadTestWriteVectors
vectors =
            ReadTestWriteVectors :: Map ShareNumber TestWriteVectors
-> [ReadVector] -> ReadTestWriteVectors
ReadTestWriteVectors
                { testWriteVectors :: Map ShareNumber TestWriteVectors
testWriteVectors = Map ShareNumber TestWriteVectors
testWriteVectors
                , readVector :: [ReadVector]
readVector = [ReadVector]
forall a. Monoid a => a
mempty
                }
    ReadTestWriteResult
result <- b
-> String
-> WriteEnablerSecret
-> ReadTestWriteVectors
-> IO ReadTestWriteResult
forall b.
Backend b =>
b
-> String
-> WriteEnablerSecret
-> ReadTestWriteVectors
-> IO ReadTestWriteResult
readvAndTestvAndWritev b
b String
storageIndex WriteEnablerSecret
writeEnablerSecret ReadTestWriteVectors
vectors
    if ReadTestWriteResult -> Bool
success ReadTestWriteResult
result
        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else WriteRefused -> IO ()
forall a e. Exception e => e -> a
throw WriteRefused
WriteRefused
writeMutableShare b
_ String
_ ShareNumber
_ WriteEnablerSecret
_ ShareData
_ Maybe ByteRanges
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"writeMutableShare got bad input"

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

withUploadSecret :: Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret :: Maybe [LeaseSecret] -> (UploadSecret -> IO a) -> IO a
withUploadSecret Maybe [LeaseSecret]
ss UploadSecret -> IO a
f =
    case (LeaseSecret -> Bool) -> [LeaseSecret] -> [LeaseSecret]
forall a. (a -> Bool) -> [a] -> [a]
filter LeaseSecret -> Bool
isUploadSecret ([LeaseSecret] -> [LeaseSecret])
-> Maybe [LeaseSecret] -> Maybe [LeaseSecret]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [LeaseSecret]
ss of
        Just [Upload UploadSecret
s] -> UploadSecret -> IO a
f UploadSecret
s
        Maybe [LeaseSecret]
_ -> WriteImmutableError -> IO a
forall e a. Exception e => e -> IO a
throwIO WriteImmutableError
MissingUploadSecret