mirror of https://github.com/voidlizard/hbs2
139 lines
4.0 KiB
Haskell
139 lines
4.0 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.Peer.Proto.LWWRef where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.OrDie
|
|
import HBS2.Base58
|
|
import HBS2.Storage
|
|
import HBS2.Hash
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Net.Auth.Schema()
|
|
|
|
import Data.Hashable hiding (Hashed)
|
|
import Data.Maybe
|
|
import Data.Word
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.Except
|
|
import Codec.Serialise
|
|
|
|
data LWWRefProtoReq (s :: CryptoScheme) =
|
|
LWWProtoGet (LWWRefKey s)
|
|
| LWWProtoSet (LWWRefKey s) (SignedBox (LWWRef s) s)
|
|
deriving stock Generic
|
|
|
|
|
|
data LWWRefProto e =
|
|
LWWRefProto1 (LWWRefProtoReq (Encryption e))
|
|
deriving stock (Generic)
|
|
|
|
data LWWRef (s :: CryptoScheme) =
|
|
LWWRef
|
|
{ lwwSeq :: Word64
|
|
, lwwValue :: HashRef
|
|
, lwwProof :: Maybe HashRef
|
|
}
|
|
deriving stock (Generic)
|
|
|
|
-- FIXME: move-to-a-right-place
|
|
-- deriving instance Data e => Data (LWWRef e)
|
|
|
|
type ForLWWRefProto (s :: CryptoScheme) = (ForSignedBox s, Serialise (LWWRefKey s))
|
|
|
|
instance ForLWWRefProto s => Serialise (LWWRefProtoReq s)
|
|
instance ForLWWRefProto (Encryption e) => Serialise (LWWRefProto e)
|
|
instance ForLWWRefProto s => Serialise (LWWRef s)
|
|
|
|
newtype LWWRefKey s =
|
|
LWWRefKey
|
|
{ fromLwwRefKey :: PubKey 'Sign s
|
|
}
|
|
deriving stock (Generic)
|
|
|
|
instance RefMetaData (LWWRefKey s)
|
|
|
|
deriving stock instance IsRefPubKey s => Eq (LWWRefKey s)
|
|
|
|
instance IsRefPubKey s => Ord (LWWRefKey s) where
|
|
compare a b = compare (serialise a) (serialise b)
|
|
|
|
instance IsRefPubKey e => Serialise (LWWRefKey e)
|
|
|
|
instance IsRefPubKey s => Hashable (LWWRefKey s) where
|
|
hashWithSalt s k = hashWithSalt s (hashObject @HbSync k)
|
|
|
|
instance IsRefPubKey s => Hashed HbSync (LWWRefKey s) where
|
|
hashObject (LWWRefKey pk) = hashObject ("lwwrefkey|" <> serialise pk)
|
|
|
|
instance IsRefPubKey s => FromStringMaybe (LWWRefKey s) where
|
|
fromStringMay s = LWWRefKey <$> fromStringMay s
|
|
|
|
instance IsRefPubKey s => IsString (LWWRefKey s) where
|
|
fromString s = fromMaybe (error "bad public key base58") (fromStringMay s)
|
|
|
|
instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (AsBase58 (LWWRefKey s)) where
|
|
pretty (AsBase58 (LWWRefKey k)) = pretty (AsBase58 k)
|
|
|
|
instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (LWWRefKey s) where
|
|
pretty (LWWRefKey k) = pretty (AsBase58 k)
|
|
|
|
|
|
instance Pretty (LWWRef e) where
|
|
pretty (LWWRef{..}) = parens ( "lwwref" <> line
|
|
<> indent 2 ( seqno <> line <> val <> line <> proof)
|
|
)
|
|
where
|
|
seqno = parens ( "seq" <+> pretty lwwSeq )
|
|
val = parens ( "value" <+> dquotes (pretty lwwValue) )
|
|
proof | isNothing lwwProof = mempty
|
|
| otherwise = parens ( "proof" <+> pretty lwwProof)
|
|
|
|
|
|
data ReadLWWRefError =
|
|
ReadLWWStorageError
|
|
| ReadLWWFormatError
|
|
| ReadLWWSignatureError
|
|
deriving stock (Show,Typeable)
|
|
|
|
readLWWRef :: forall s m . ( MonadIO m
|
|
, MonadError ReadLWWRefError m
|
|
, ForLWWRefProto s
|
|
, Signatures s
|
|
, IsRefPubKey s
|
|
)
|
|
=> AnyStorage
|
|
-> LWWRefKey s
|
|
-> m (Maybe (LWWRef s))
|
|
|
|
readLWWRef sto key = runMaybeT do
|
|
getRef sto key
|
|
>>= toMPlus
|
|
>>= getBlock sto
|
|
>>= toMPlus
|
|
<&> deserialiseOrFail @(SignedBox (LWWRef s) s)
|
|
>>= orThrowError ReadLWWFormatError
|
|
<&> unboxSignedBox0
|
|
>>= orThrowError ReadLWWSignatureError
|
|
<&> snd
|
|
|
|
updateLWWRef :: forall s m . ( ForLWWRefProto s
|
|
, MonadIO m
|
|
, Signatures s
|
|
, IsRefPubKey s
|
|
)
|
|
=> AnyStorage
|
|
-> LWWRefKey s
|
|
-> PrivKey 'Sign s
|
|
-> LWWRef s
|
|
-> m (Maybe HashRef)
|
|
|
|
updateLWWRef sto k sk v = do
|
|
let box = makeSignedBox @s (fromLwwRefKey k) sk v
|
|
runMaybeT do
|
|
hx <- putBlock sto (serialise box) >>= toMPlus
|
|
updateRef sto k hx
|
|
pure (HashRef hx)
|
|
|