{- | Types involved in the implementation of the backend for a Tahoe-LAFS
 storage server.
-}
module Tahoe.Storage.Backend where

import Control.Exception (
    Exception,
 )
import Data.Aeson (
    FromJSON (..),
    FromJSONKey (..),
    ToJSON (..),
    Value (String),
    object,
    withObject,
    withText,
    (.:),
    (.=),
 )
import Data.ByteArray (constEq)
import qualified Data.ByteString as B
import qualified "base64-bytestring" Data.ByteString.Base64 as Base64
import Data.Hashable (Hashable (hashWithSalt))
import Data.Map.Merge.Strict (merge, preserveMissing, zipWithMatched)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text.Encoding as T
import GHC.Generics (
    Generic,
 )
import Network.HTTP.Types (
    ByteRanges,
 )

-- | A human-readable description of the backend software in use.
type ApplicationVersion = B.ByteString

-- | Give certain operational details about this storage server.
data Version1Parameters = Version1Parameters
    { maximumImmutableShareSize :: Size
    , maximumMutableShareSize :: Size
    , availableSpace :: Size
    }
    deriving (Show, Eq, Generic)

-- | Carry a version string and operational parameters.
data Version = Version
    { parameters :: Version1Parameters
    , applicationVersion :: ApplicationVersion
    }
    deriving (Show, Eq, Generic)

-- | The number of bytes in some data.
type Size = Integer

{- | A position in some data identified by a number of bytes into that data
 from the beginning.
-}
type Offset = Integer

{- | Some ranges of data, possibly.  Nothing conventionally refers to the
 entire data.
-}
type QueryRange = Maybe ByteRanges

{- | An opaque identifier for a single storage area.  Multiple storage objects
 may exist at one storage index if they have different share numbers.  TODO:
 This should probably be ByteString instead.
-}
type StorageIndex = String

-- | Some data.
type ShareData = B.ByteString

{- | The identifier of a distinct storage object, unique within the context of
 a particular storage index.  In practice, values are in the range [0..255]
 (endpoints included).
-}
newtype ShareNumber = ShareNumber Integer
    deriving
        ( Show
        , Eq
        , Ord
        , Generic
        )
    deriving newtype
        ( ToJSON
        , FromJSON
        , FromJSONKey
        )

instance Hashable ShareNumber where
    hashWithSalt i (ShareNumber num) = hashWithSalt i num

{- | A new type for which we can define our own CBOR serialisation rules.  The
 cborg library provides a Serialise instance for Set which is not compatible
 with the representation required by Tahoe-LAFS.
-}
newtype CBORSet a = CBORSet
    { getCBORSet :: Set.Set a
    }
    deriving newtype (ToJSON, FromJSON, Show, Eq)

-- | Describe a client-detected incidence of data corruption.
newtype CorruptionDetails = CorruptionDetails
    { reason :: String
    }
    deriving (Show, Eq, Generic)

{- | A secret shared between a client and this storage server for the purpose
 of authorizing certain operations related to immutable uploads.
-}
newtype UploadSecret = UploadSecret B.ByteString

instance Eq UploadSecret where
    (UploadSecret left) == (UploadSecret right) = constEq left right

{- | A secret shared between an SSK write capability holder and this storage
 server for the purpose of authorizing write operations on a mutable object.
-}
newtype WriteEnablerSecret = WriteEnablerSecret B.ByteString

instance Eq WriteEnablerSecret where
    (WriteEnablerSecret left) == (WriteEnablerSecret right) = constEq left right

-- | Describe tests, reads, and writes to perform on a mutable object.
data ReadTestWriteVectors = ReadTestWriteVectors
    { testWriteVectors :: Map.Map ShareNumber TestWriteVectors
    , readVector :: [ReadVector]
    }
    deriving (Show, Eq, Generic)

-- | Describe tests and writes to perform on a mutable object.
data TestWriteVectors = TestWriteVectors
    { test :: [TestVector]
    , write :: [WriteVector]
    , -- | If given, truncate or extend the object to the given size.  If
      -- necessary, fill new space with NUL.
      newLength :: Maybe Integer
    }
    deriving (Show, Eq, Generic, ToJSON, FromJSON)

-- | Describe a single test to perform on a mutable object.
data TestVector = TestVector
    { testOffset :: Offset
    , testSize :: Size
    , operator :: TestOperator
    , specimen :: ShareData
    }
    deriving (Show, Eq, Generic)

-- | Describe a single write to perform on a mutable object.
data WriteVector = WriteVector
    { writeOffset :: Offset
    , shareData :: ShareData
    }
    deriving (Show, Eq, Generic)

-- | Describe one read to perform on an immutable object.
data ReadVector = ReadVector
    { offset :: Offset
    , readSize :: Size
    }
    deriving (Show, Eq, Generic)

{- | The result of a request to read and/or write some data from/to some
 shares.
-}
data ReadTestWriteResult = ReadTestWriteResult
    { success :: Bool
    , readData :: ReadResult
    }
    deriving (Show, Eq, Generic)

-- | The result of a request to read some data from some shares.
type ReadResult = Map.Map ShareNumber [ShareData]

instance Semigroup TestWriteVectors where
    (TestWriteVectors testL writeL _) <> (TestWriteVectors testR writeR newLengthR) =
        TestWriteVectors (testL <> testR) (writeL <> writeR) newLengthR

instance Monoid TestWriteVectors where
    mempty = TestWriteVectors mempty mempty Nothing

instance Monoid ReadTestWriteVectors where
    mempty = ReadTestWriteVectors mempty []

instance Semigroup ReadTestWriteVectors where
    (ReadTestWriteVectors wv0 rv0) <> (ReadTestWriteVectors wv1 rv1) =
        ReadTestWriteVectors (merge preserveMissing preserveMissing (zipWithMatched $ \_ l r -> l <> r) wv0 wv1) (rv0 <> rv1)

{- | Create a ReadTestWriteVectors which performs one read at the given offset
 of the given size.
-}
readv :: Offset -> Size -> ReadTestWriteVectors
readv offset size = mempty{readVector = [ReadVector offset size]}

{- | Create a ReadTestWriteVectors which performs one write on the given share
 number at the given offset.
-}
writev :: ShareNumber -> Offset -> ShareData -> ReadTestWriteVectors
writev shareNum offset bytes = mempty{testWriteVectors = Map.singleton shareNum (mempty{write = [WriteVector offset bytes]})}

{- | Create a ReadTestWriteVectors which performs one test on the given share
 number using the given specimen.
-}
testv :: ShareNumber -> Offset -> ShareData -> ReadTestWriteVectors
testv shareNum offset specimen =
    mempty
        { testWriteVectors = Map.singleton shareNum (mempty{test = [TestVector offset (fromIntegral $ B.length specimen) Eq specimen]})
        }

-- | Describe some allocations for immutable objects requested by a client.
data AllocateBuckets = AllocateBuckets
    { shareNumbers :: [ShareNumber]
    , allocatedSize :: Size
    }
    deriving (Show, Eq, Generic)

{- | Describe the server's willingness to allocate space for some immutable
 objects.
-}
data AllocationResult = AllocationResult
    { alreadyHave :: [ShareNumber]
    , allocated :: [ShareNumber]
    }
    deriving (Show, Eq, Generic)

instance Semigroup AllocationResult where
    AllocationResult xa ya <> AllocationResult xb yb = AllocationResult (xa <> xb) (ya <> yb)

instance Monoid AllocationResult where
    mempty = AllocationResult mempty mempty

{- | One of several kinds of shared secrets for authorizing a client to
 perform various operations.
-}
data LeaseSecret = Renew B.ByteString | Cancel B.ByteString | Upload UploadSecret | Write WriteEnablerSecret

-- XXX Most of these operators have been removed from the spec.
data TestOperator
    = Lt
    | Le
    | Eq
    | Ne
    | Ge
    | Gt
    deriving (Show, Eq, Generic, ToJSON, FromJSON)

-- | A ByteString wrapper which can have its own serialization semantics.
newtype Base64 = Base64 {unBase64 :: B.ByteString}

-- | Serialize a ByteString by encoding with Base64.
instance ToJSON Base64 where
    toJSON = String . T.decodeLatin1 . Base64.encode . unBase64

-- | Deserialize a ByteString which has been encoded with Base64.
instance FromJSON Base64 where
    parseJSON =
        withText
            "Base64-encoded ByteString"
            ( \bs ->
                case Base64.decode $ T.encodeUtf8 bs of
                    Left err -> fail ("Base64 decoding failed: " <> err)
                    Right bytes -> pure $ Base64 bytes
            )

-- | Serialize to the JSON as specified by the specification.
instance ToJSON TestVector where
    toJSON (TestVector{..}) =
        object ["offset" .= testOffset, "size" .= testSize, "specimen" .= Base64 specimen]

-- | Deserialize from JSON as specified by the specification.
instance FromJSON TestVector where
    parseJSON = withObject "TestVector" $ \v ->
        TestVector <$> v .: "offset" <*> v .: "size" <*> pure Eq <*> (unBase64 <$> v .: "specimen")

-- | Serialize to the JSON as specified by the specification.
instance ToJSON WriteVector where
    toJSON (WriteVector{..}) =
        object ["offset" .= writeOffset, "data" .= Base64 shareData]

-- | Deserialize from JSON as specified by the specification.
instance FromJSON WriteVector where
    parseJSON = withObject "WriteVector" $ \v ->
        WriteVector <$> v .: "offset" <*> (unBase64 <$> v .: "data")

{- | Exceptional cases which might be encounted by various backend for
 operations related to immutable shares.
-}
data WriteImmutableError
    = -- | Used to reject an immutable allocate or upload with no upload secret.
      MissingUploadSecret
    | -- | Used to reject an immutable upload with an incorrect upload secret.
      IncorrectUploadSecret
    | -- | Used to reject an immutable allocate of a size that does not match
      -- existing shares with the same storage index.
      ShareSizeMismatch
    | -- | Used to reject an immutable allocate of a size greater than the
      -- maximum allowed by the server.
      MaximumShareSizeExceeded
        { maximumShareSizeExceededLimit :: Integer
        , maximumShareSizeExceededGiven :: Integer
        }
    | -- | Used to reject an immutable write to a share that is already
      -- completely written.
      ImmutableShareAlreadyWritten
    | -- | Used to reject an immutable write to a share which has not been
      -- allocated.
      ShareNotAllocated
    | -- | Used to reject an immutable write that overlaps with data that has
      -- already been written.
      ConflictingWrite
    deriving (Ord, Eq, Show)

instance Exception WriteImmutableError

{- | Exceptional cases which might be encounted by various backend for
 operations related to mutable shares.
-}
data WriteMutableError
    = -- | Used to reject a mutable write with no write enabler secret.
      MissingWriteEnablerSecret
    | -- | Used to reject a mutable write with an incorrect write enabler secret.
      IncorrectWriteEnablerSecret
    deriving (Ord, Eq, Show)

instance Exception WriteMutableError

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
    -- XXX Return should indicate what remains to be written
    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 ()