module Erebos.State (
    LocalState(..),
    SharedState, SharedType(..),
    SharedTypeID, mkSharedTypeID,

    MonadHead(..),
    updateLocalHead_,

    loadLocalStateHead,

    updateSharedState, updateSharedState_,
    lookupSharedValue, makeSharedStateUpdate,

    localIdentity,
    headLocalIdentity,

    mergeSharedIdentity,
    updateSharedIdentity,
    interactiveIdentityUpdate,
) where

import Control.Monad.Except
import Control.Monad.Reader

import Data.Foldable
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import Data.UUID (UUID)
import qualified Data.UUID as U

import System.IO

import Erebos.Identity
import Erebos.PubKey
import Erebos.Storage
import Erebos.Storage.Merge

data LocalState = LocalState
    { LocalState -> Stored (Signed ExtendedIdentityData)
lsIdentity :: Stored (Signed ExtendedIdentityData)
    , LocalState -> [Stored SharedState]
lsShared :: [Stored SharedState]
    }

data SharedState = SharedState
    { SharedState -> [Stored SharedState]
ssPrev :: [Stored SharedState]
    , SharedState -> Maybe SharedTypeID
ssType :: Maybe SharedTypeID
    , SharedState -> [Ref]
ssValue :: [Ref]
    }

newtype SharedTypeID = SharedTypeID UUID
    deriving (SharedTypeID -> SharedTypeID -> Bool
(SharedTypeID -> SharedTypeID -> Bool)
-> (SharedTypeID -> SharedTypeID -> Bool) -> Eq SharedTypeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SharedTypeID -> SharedTypeID -> Bool
== :: SharedTypeID -> SharedTypeID -> Bool
$c/= :: SharedTypeID -> SharedTypeID -> Bool
/= :: SharedTypeID -> SharedTypeID -> Bool
Eq, Eq SharedTypeID
Eq SharedTypeID =>
(SharedTypeID -> SharedTypeID -> Ordering)
-> (SharedTypeID -> SharedTypeID -> Bool)
-> (SharedTypeID -> SharedTypeID -> Bool)
-> (SharedTypeID -> SharedTypeID -> Bool)
-> (SharedTypeID -> SharedTypeID -> Bool)
-> (SharedTypeID -> SharedTypeID -> SharedTypeID)
-> (SharedTypeID -> SharedTypeID -> SharedTypeID)
-> Ord SharedTypeID
SharedTypeID -> SharedTypeID -> Bool
SharedTypeID -> SharedTypeID -> Ordering
SharedTypeID -> SharedTypeID -> SharedTypeID
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
$ccompare :: SharedTypeID -> SharedTypeID -> Ordering
compare :: SharedTypeID -> SharedTypeID -> Ordering
$c< :: SharedTypeID -> SharedTypeID -> Bool
< :: SharedTypeID -> SharedTypeID -> Bool
$c<= :: SharedTypeID -> SharedTypeID -> Bool
<= :: SharedTypeID -> SharedTypeID -> Bool
$c> :: SharedTypeID -> SharedTypeID -> Bool
> :: SharedTypeID -> SharedTypeID -> Bool
$c>= :: SharedTypeID -> SharedTypeID -> Bool
>= :: SharedTypeID -> SharedTypeID -> Bool
$cmax :: SharedTypeID -> SharedTypeID -> SharedTypeID
max :: SharedTypeID -> SharedTypeID -> SharedTypeID
$cmin :: SharedTypeID -> SharedTypeID -> SharedTypeID
min :: SharedTypeID -> SharedTypeID -> SharedTypeID
Ord, UUID -> SharedTypeID
SharedTypeID -> UUID
(SharedTypeID -> UUID)
-> (UUID -> SharedTypeID) -> StorableUUID SharedTypeID
forall a. (a -> UUID) -> (UUID -> a) -> StorableUUID a
$ctoUUID :: SharedTypeID -> UUID
toUUID :: SharedTypeID -> UUID
$cfromUUID :: UUID -> SharedTypeID
fromUUID :: UUID -> SharedTypeID
StorableUUID)

mkSharedTypeID :: String -> SharedTypeID
mkSharedTypeID :: String -> SharedTypeID
mkSharedTypeID = SharedTypeID
-> (UUID -> SharedTypeID) -> Maybe UUID -> SharedTypeID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SharedTypeID
forall a. HasCallStack => String -> a
error String
"Invalid shared type ID") UUID -> SharedTypeID
SharedTypeID (Maybe UUID -> SharedTypeID)
-> (String -> Maybe UUID) -> String -> SharedTypeID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe UUID
U.fromString

class Mergeable a => SharedType a where
    sharedTypeID :: proxy a -> SharedTypeID

instance Storable LocalState where
    store' :: LocalState -> Store
store' LocalState
st = (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c)
 -> Store)
-> (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
forall a b. (a -> b) -> a -> b
$ do
        String -> Stored (Signed ExtendedIdentityData) -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"id" (Stored (Signed ExtendedIdentityData) -> StoreRec c)
-> Stored (Signed ExtendedIdentityData) -> StoreRec c
forall a b. (a -> b) -> a -> b
$ LocalState -> Stored (Signed ExtendedIdentityData)
lsIdentity LocalState
st
        (Stored SharedState -> StoreRec c)
-> [Stored SharedState] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Stored SharedState -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"shared") ([Stored SharedState] -> StoreRec c)
-> [Stored SharedState] -> StoreRec c
forall a b. (a -> b) -> a -> b
$ LocalState -> [Stored SharedState]
lsShared LocalState
st

    load' :: Load LocalState
load' = LoadRec LocalState -> Load LocalState
forall a. LoadRec a -> Load a
loadRec (LoadRec LocalState -> Load LocalState)
-> LoadRec LocalState -> Load LocalState
forall a b. (a -> b) -> a -> b
$ Stored (Signed ExtendedIdentityData)
-> [Stored SharedState] -> LocalState
LocalState
        (Stored (Signed ExtendedIdentityData)
 -> [Stored SharedState] -> LocalState)
-> LoadRec (Stored (Signed ExtendedIdentityData))
-> LoadRec ([Stored SharedState] -> LocalState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec (Stored (Signed ExtendedIdentityData))
forall a. Storable a => String -> LoadRec a
loadRef String
"id"
        LoadRec ([Stored SharedState] -> LocalState)
-> LoadRec [Stored SharedState] -> LoadRec LocalState
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec [Stored SharedState]
forall a. Storable a => String -> LoadRec [a]
loadRefs String
"shared"

instance HeadType LocalState where
    headTypeID :: forall (proxy :: * -> *). proxy LocalState -> HeadTypeID
headTypeID proxy LocalState
_ = String -> HeadTypeID
mkHeadTypeID String
"1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e"

instance Storable SharedState where
    store' :: SharedState -> Store
store' SharedState
st = (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c)
 -> Store)
-> (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
forall a b. (a -> b) -> a -> b
$ do
        (Stored SharedState -> StoreRec c)
-> [Stored SharedState] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Stored SharedState -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"PREV") ([Stored SharedState] -> StoreRec c)
-> [Stored SharedState] -> StoreRec c
forall a b. (a -> b) -> a -> b
$ SharedState -> [Stored SharedState]
ssPrev SharedState
st
        String -> Maybe SharedTypeID -> StoreRec c
forall a (c :: * -> *).
StorableUUID a =>
String -> Maybe a -> StoreRec c
storeMbUUID String
"type" (Maybe SharedTypeID -> StoreRec c)
-> Maybe SharedTypeID -> StoreRec c
forall a b. (a -> b) -> a -> b
$ SharedState -> Maybe SharedTypeID
ssType SharedState
st
        (Ref -> StoreRec c) -> [Ref] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Ref -> StoreRec c
forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
"value") ([Ref] -> StoreRec c) -> [Ref] -> StoreRec c
forall a b. (a -> b) -> a -> b
$ SharedState -> [Ref]
ssValue SharedState
st

    load' :: Load SharedState
load' = LoadRec SharedState -> Load SharedState
forall a. LoadRec a -> Load a
loadRec (LoadRec SharedState -> Load SharedState)
-> LoadRec SharedState -> Load SharedState
forall a b. (a -> b) -> a -> b
$ [Stored SharedState] -> Maybe SharedTypeID -> [Ref] -> SharedState
SharedState
        ([Stored SharedState]
 -> Maybe SharedTypeID -> [Ref] -> SharedState)
-> LoadRec [Stored SharedState]
-> LoadRec (Maybe SharedTypeID -> [Ref] -> SharedState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec [Stored SharedState]
forall a. Storable a => String -> LoadRec [a]
loadRefs String
"PREV"
        LoadRec (Maybe SharedTypeID -> [Ref] -> SharedState)
-> LoadRec (Maybe SharedTypeID) -> LoadRec ([Ref] -> SharedState)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe SharedTypeID)
forall a. StorableUUID a => String -> LoadRec (Maybe a)
loadMbUUID String
"type"
        LoadRec ([Ref] -> SharedState)
-> LoadRec [Ref] -> LoadRec SharedState
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec [Ref]
loadRawRefs String
"value"

instance SharedType (Maybe ComposedIdentity) where
    sharedTypeID :: forall (proxy :: * -> *).
proxy (Maybe (Identity [])) -> SharedTypeID
sharedTypeID proxy (Maybe (Identity []))
_ = String -> SharedTypeID
mkSharedTypeID String
"0c6c1fe0-f2d7-4891-926b-c332449f7871"


class (MonadIO m, MonadStorage m) => MonadHead a m where
    updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b

updateLocalHead_ :: MonadHead a m => (Stored a -> m (Stored a)) -> m ()
updateLocalHead_ :: forall a (m :: * -> *).
MonadHead a m =>
(Stored a -> m (Stored a)) -> m ()
updateLocalHead_ Stored a -> m (Stored a)
f = (Stored a -> m (Stored a, ())) -> m ()
forall b. (Stored a -> m (Stored a, b)) -> m b
forall a (m :: * -> *) b.
MonadHead a m =>
(Stored a -> m (Stored a, b)) -> m b
updateLocalHead ((Stored a -> (Stored a, ())) -> m (Stored a) -> m (Stored a, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,()) (m (Stored a) -> m (Stored a, ()))
-> (Stored a -> m (Stored a)) -> Stored a -> m (Stored a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored a -> m (Stored a)
f)

instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
    updateLocalHead :: forall b.
(Stored a -> ReaderT (Head a) m (Stored a, b))
-> ReaderT (Head a) m b
updateLocalHead Stored a -> ReaderT (Head a) m (Stored a, b)
f = do
        Head a
h <- ReaderT (Head a) m (Head a)
forall r (m :: * -> *). MonadReader r m => m r
ask
        (Maybe (Head a), b) -> b
forall a b. (a, b) -> b
snd ((Maybe (Head a), b) -> b)
-> ReaderT (Head a) m (Maybe (Head a), b) -> ReaderT (Head a) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Head a
-> (Stored a -> ReaderT (Head a) m (Stored a, b))
-> ReaderT (Head a) m (Maybe (Head a), b)
forall a (m :: * -> *) b.
(HeadType a, MonadIO m) =>
Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
updateHead Head a
h Stored a -> ReaderT (Head a) m (Stored a, b)
f


loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState)
loadLocalStateHead :: forall (m :: * -> *). MonadIO m => Storage -> m (Head LocalState)
loadLocalStateHead Storage
st = Storage -> m [Head LocalState]
forall a (m :: * -> *).
(MonadIO m, HeadType a) =>
Storage -> m [Head a]
loadHeads Storage
st m [Head LocalState]
-> ([Head LocalState] -> m (Head LocalState))
-> m (Head LocalState)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Head LocalState
h:[Head LocalState]
_) -> Head LocalState -> m (Head LocalState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Head LocalState
h
    [] -> IO (Head LocalState) -> m (Head LocalState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Head LocalState) -> m (Head LocalState))
-> IO (Head LocalState) -> m (Head LocalState)
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStr String
"Name: "
        Handle -> IO ()
hFlush Handle
stdout
        Text
name <- IO Text
T.getLine

        String -> IO ()
putStr String
"Device: "
        Handle -> IO ()
hFlush Handle
stdout
        Text
devName <- IO Text
T.getLine

        Maybe UnifiedIdentity
owner <- if
            | Text -> Bool
T.null Text
name -> Maybe UnifiedIdentity -> IO (Maybe UnifiedIdentity)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnifiedIdentity
forall a. Maybe a
Nothing
            | Bool
otherwise -> UnifiedIdentity -> Maybe UnifiedIdentity
forall a. a -> Maybe a
Just (UnifiedIdentity -> Maybe UnifiedIdentity)
-> IO UnifiedIdentity -> IO (Maybe UnifiedIdentity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage
-> Maybe Text -> Maybe UnifiedIdentity -> IO UnifiedIdentity
createIdentity Storage
st (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) Maybe UnifiedIdentity
forall a. Maybe a
Nothing

        UnifiedIdentity
identity <- Storage
-> Maybe Text -> Maybe UnifiedIdentity -> IO UnifiedIdentity
createIdentity Storage
st (if Text -> Bool
T.null Text
devName then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
devName) Maybe UnifiedIdentity
owner

        Stored SharedState
shared <- Storage -> SharedState -> IO (Stored SharedState)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st (SharedState -> IO (Stored SharedState))
-> SharedState -> IO (Stored SharedState)
forall a b. (a -> b) -> a -> b
$ SharedState
            { ssPrev :: [Stored SharedState]
ssPrev = []
            , ssType :: Maybe SharedTypeID
ssType = SharedTypeID -> Maybe SharedTypeID
forall a. a -> Maybe a
Just (SharedTypeID -> Maybe SharedTypeID)
-> SharedTypeID -> Maybe SharedTypeID
forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *). SharedType a => proxy a -> SharedTypeID
sharedTypeID @(Maybe ComposedIdentity) Proxy (Maybe (Identity []))
forall {k} (t :: k). Proxy t
Proxy
            , ssValue :: [Ref]
ssValue = [Stored (Signed ExtendedIdentityData) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Signed ExtendedIdentityData) -> Ref)
-> Stored (Signed ExtendedIdentityData) -> Ref
forall a b. (a -> b) -> a -> b
$ UnifiedIdentity -> Stored (Signed ExtendedIdentityData)
idExtData (UnifiedIdentity -> Stored (Signed ExtendedIdentityData))
-> UnifiedIdentity -> Stored (Signed ExtendedIdentityData)
forall a b. (a -> b) -> a -> b
$ UnifiedIdentity -> Maybe UnifiedIdentity -> UnifiedIdentity
forall a. a -> Maybe a -> a
fromMaybe UnifiedIdentity
identity Maybe UnifiedIdentity
owner]
            }
        Storage -> LocalState -> IO (Head LocalState)
forall a (m :: * -> *).
(MonadIO m, HeadType a) =>
Storage -> a -> m (Head a)
storeHead Storage
st (LocalState -> IO (Head LocalState))
-> LocalState -> IO (Head LocalState)
forall a b. (a -> b) -> a -> b
$ LocalState
            { lsIdentity :: Stored (Signed ExtendedIdentityData)
lsIdentity = UnifiedIdentity -> Stored (Signed ExtendedIdentityData)
idExtData UnifiedIdentity
identity
            , lsShared :: [Stored SharedState]
lsShared = [Stored SharedState
shared]
            }

localIdentity :: LocalState -> UnifiedIdentity
localIdentity :: LocalState -> UnifiedIdentity
localIdentity LocalState
ls = UnifiedIdentity
-> (UnifiedIdentity -> UnifiedIdentity)
-> Maybe UnifiedIdentity
-> UnifiedIdentity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> UnifiedIdentity
forall a. HasCallStack => String -> a
error String
"failed to verify local identity")
    ([Stored (Signed ExtendedIdentityData)]
-> UnifiedIdentity -> UnifiedIdentity
forall (m :: * -> *).
[Stored (Signed ExtendedIdentityData)] -> Identity m -> Identity m
updateOwners ([Stored (Signed ExtendedIdentityData)]
 -> UnifiedIdentity -> UnifiedIdentity)
-> [Stored (Signed ExtendedIdentityData)]
-> UnifiedIdentity
-> UnifiedIdentity
forall a b. (a -> b) -> a -> b
$ [Stored (Signed ExtendedIdentityData)]
-> (Identity [] -> [Stored (Signed ExtendedIdentityData)])
-> Maybe (Identity [])
-> [Stored (Signed ExtendedIdentityData)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Identity [] -> [Stored (Signed ExtendedIdentityData)]
forall (m :: * -> *).
Identity m -> m (Stored (Signed ExtendedIdentityData))
idExtDataF (Maybe (Identity []) -> [Stored (Signed ExtendedIdentityData)])
-> Maybe (Identity []) -> [Stored (Signed ExtendedIdentityData)]
forall a b. (a -> b) -> a -> b
$ [Stored SharedState] -> Maybe (Identity [])
forall a. SharedType a => [Stored SharedState] -> a
lookupSharedValue ([Stored SharedState] -> Maybe (Identity []))
-> [Stored SharedState] -> Maybe (Identity [])
forall a b. (a -> b) -> a -> b
$ LocalState -> [Stored SharedState]
lsShared LocalState
ls)
    (Stored (Signed ExtendedIdentityData) -> Maybe UnifiedIdentity
validateExtendedIdentity (Stored (Signed ExtendedIdentityData) -> Maybe UnifiedIdentity)
-> Stored (Signed ExtendedIdentityData) -> Maybe UnifiedIdentity
forall a b. (a -> b) -> a -> b
$ LocalState -> Stored (Signed ExtendedIdentityData)
lsIdentity LocalState
ls)

headLocalIdentity :: Head LocalState -> UnifiedIdentity
headLocalIdentity :: Head LocalState -> UnifiedIdentity
headLocalIdentity = LocalState -> UnifiedIdentity
localIdentity (LocalState -> UnifiedIdentity)
-> (Head LocalState -> LocalState)
-> Head LocalState
-> UnifiedIdentity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Head LocalState -> LocalState
forall a. Head a -> a
headObject


updateSharedState_ :: forall a m. (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState)
updateSharedState_ :: forall a (m :: * -> *).
(SharedType a, MonadHead LocalState m) =>
(a -> m a) -> Stored LocalState -> m (Stored LocalState)
updateSharedState_ a -> m a
f = ((Stored LocalState, ()) -> Stored LocalState)
-> m (Stored LocalState, ()) -> m (Stored LocalState)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Stored LocalState, ()) -> Stored LocalState
forall a b. (a, b) -> a
fst (m (Stored LocalState, ()) -> m (Stored LocalState))
-> (Stored LocalState -> m (Stored LocalState, ()))
-> Stored LocalState
-> m (Stored LocalState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m (a, ())) -> Stored LocalState -> m (Stored LocalState, ())
forall a b (m :: * -> *).
(SharedType a, MonadHead LocalState m) =>
(a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
updateSharedState ((a -> (a, ())) -> m a -> m (a, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,()) (m a -> m (a, ())) -> (a -> m a) -> a -> m (a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
f)

updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
updateSharedState :: forall a b (m :: * -> *).
(SharedType a, MonadHead LocalState m) =>
(a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
updateSharedState a -> m (a, b)
f = \Stored LocalState
ls -> do
    let shared :: [Stored SharedState]
shared = LocalState -> [Stored SharedState]
lsShared (LocalState -> [Stored SharedState])
-> LocalState -> [Stored SharedState]
forall a b. (a -> b) -> a -> b
$ Stored LocalState -> LocalState
forall a. Stored a -> a
fromStored Stored LocalState
ls
        val :: a
val = [Stored SharedState] -> a
forall a. SharedType a => [Stored SharedState] -> a
lookupSharedValue [Stored SharedState]
shared
    Storage
st <- m Storage
forall (m :: * -> *). MonadStorage m => m Storage
getStorage
    (a
val', b
x) <- a -> m (a, b)
f a
val
    (,b
x) (Stored LocalState -> (Stored LocalState, b))
-> m (Stored LocalState) -> m (Stored LocalState, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if a -> [Stored (Component a)]
forall a. Mergeable a => a -> [Stored (Component a)]
toComponents a
val' [Stored (Component a)] -> [Stored (Component a)] -> Bool
forall a. Eq a => a -> a -> Bool
== a -> [Stored (Component a)]
forall a. Mergeable a => a -> [Stored (Component a)]
toComponents a
val
                then Stored LocalState -> m (Stored LocalState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Stored LocalState
ls
                else do Stored SharedState
shared' <- Storage -> a -> [Stored SharedState] -> m (Stored SharedState)
forall a (m :: * -> *).
(MonadIO m, SharedType a) =>
Storage -> a -> [Stored SharedState] -> m (Stored SharedState)
makeSharedStateUpdate Storage
st a
val' [Stored SharedState]
shared
                        Storage -> LocalState -> m (Stored LocalState)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st (Stored LocalState -> LocalState
forall a. Stored a -> a
fromStored Stored LocalState
ls) { lsShared = [shared'] }

lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a
lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a
lookupSharedValue = [Stored (Component a)] -> a
forall a. Mergeable a => [Stored (Component a)] -> a
mergeSorted ([Stored (Component a)] -> a)
-> ([Stored SharedState] -> [Stored (Component a)])
-> [Stored SharedState]
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored (Component a)] -> [Stored (Component a)]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors ([Stored (Component a)] -> [Stored (Component a)])
-> ([Stored SharedState] -> [Stored (Component a)])
-> [Stored SharedState]
-> [Stored (Component a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ref -> Stored (Component a)) -> [Ref] -> [Stored (Component a)]
forall a b. (a -> b) -> [a] -> [b]
map Ref -> Stored (Component a)
forall a. Storable a => Ref -> Stored a
wrappedLoad ([Ref] -> [Stored (Component a)])
-> ([Stored SharedState] -> [Ref])
-> [Stored SharedState]
-> [Stored (Component a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stored SharedState -> [Ref]) -> [Stored SharedState] -> [Ref]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SharedState -> [Ref]
ssValue (SharedState -> [Ref])
-> (Stored SharedState -> SharedState)
-> Stored SharedState
-> [Ref]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored SharedState -> SharedState
forall a. Stored a -> a
fromStored) ([Stored SharedState] -> [Ref])
-> ([Stored SharedState] -> [Stored SharedState])
-> [Stored SharedState]
-> [Ref]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored SharedState] -> [Stored SharedState]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors ([Stored SharedState] -> [Stored SharedState])
-> ([Stored SharedState] -> [Stored SharedState])
-> [Stored SharedState]
-> [Stored SharedState]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored SharedState] -> [Stored SharedState]
helper
    where helper :: [Stored SharedState] -> [Stored SharedState]
helper (Stored SharedState
x:[Stored SharedState]
xs) | Just SharedTypeID
sid <- SharedState -> Maybe SharedTypeID
ssType (Stored SharedState -> SharedState
forall a. Stored a -> a
fromStored Stored SharedState
x), SharedTypeID
sid SharedTypeID -> SharedTypeID -> Bool
forall a. Eq a => a -> a -> Bool
== forall a (proxy :: * -> *). SharedType a => proxy a -> SharedTypeID
sharedTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy = Stored SharedState
x Stored SharedState -> [Stored SharedState] -> [Stored SharedState]
forall a. a -> [a] -> [a]
: [Stored SharedState] -> [Stored SharedState]
helper [Stored SharedState]
xs
                        | Bool
otherwise = [Stored SharedState] -> [Stored SharedState]
helper ([Stored SharedState] -> [Stored SharedState])
-> [Stored SharedState] -> [Stored SharedState]
forall a b. (a -> b) -> a -> b
$ SharedState -> [Stored SharedState]
ssPrev (Stored SharedState -> SharedState
forall a. Stored a -> a
fromStored Stored SharedState
x) [Stored SharedState]
-> [Stored SharedState] -> [Stored SharedState]
forall a. [a] -> [a] -> [a]
++ [Stored SharedState]
xs
          helper [] = []

makeSharedStateUpdate :: forall a m. MonadIO m => SharedType a => Storage -> a -> [Stored SharedState] -> m (Stored SharedState)
makeSharedStateUpdate :: forall a (m :: * -> *).
(MonadIO m, SharedType a) =>
Storage -> a -> [Stored SharedState] -> m (Stored SharedState)
makeSharedStateUpdate Storage
st a
val [Stored SharedState]
prev = IO (Stored SharedState) -> m (Stored SharedState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Stored SharedState) -> m (Stored SharedState))
-> IO (Stored SharedState) -> m (Stored SharedState)
forall a b. (a -> b) -> a -> b
$ Storage -> SharedState -> IO (Stored SharedState)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st SharedState
    { ssPrev :: [Stored SharedState]
ssPrev = [Stored SharedState]
prev
    , ssType :: Maybe SharedTypeID
ssType = SharedTypeID -> Maybe SharedTypeID
forall a. a -> Maybe a
Just (SharedTypeID -> Maybe SharedTypeID)
-> SharedTypeID -> Maybe SharedTypeID
forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *). SharedType a => proxy a -> SharedTypeID
sharedTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
    , ssValue :: [Ref]
ssValue = Stored (Component a) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Component a) -> Ref) -> [Stored (Component a)] -> [Ref]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [Stored (Component a)]
forall a. Mergeable a => a -> [Stored (Component a)]
toComponents a
val
    }


mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity
mergeSharedIdentity :: forall (m :: * -> *).
(MonadHead LocalState m, MonadError String m) =>
m UnifiedIdentity
mergeSharedIdentity = (Stored LocalState -> m (Stored LocalState, UnifiedIdentity))
-> m UnifiedIdentity
forall b. (Stored LocalState -> m (Stored LocalState, b)) -> m b
forall a (m :: * -> *) b.
MonadHead a m =>
(Stored a -> m (Stored a, b)) -> m b
updateLocalHead ((Stored LocalState -> m (Stored LocalState, UnifiedIdentity))
 -> m UnifiedIdentity)
-> (Stored LocalState -> m (Stored LocalState, UnifiedIdentity))
-> m UnifiedIdentity
forall a b. (a -> b) -> a -> b
$ (Maybe (Identity []) -> m (Maybe (Identity []), UnifiedIdentity))
-> Stored LocalState -> m (Stored LocalState, UnifiedIdentity)
forall a b (m :: * -> *).
(SharedType a, MonadHead LocalState m) =>
(a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
updateSharedState ((Maybe (Identity []) -> m (Maybe (Identity []), UnifiedIdentity))
 -> Stored LocalState -> m (Stored LocalState, UnifiedIdentity))
-> (Maybe (Identity [])
    -> m (Maybe (Identity []), UnifiedIdentity))
-> Stored LocalState
-> m (Stored LocalState, UnifiedIdentity)
forall a b. (a -> b) -> a -> b
$ \case
    Just Identity []
cidentity -> do
        UnifiedIdentity
identity <- Identity [] -> m UnifiedIdentity
forall (m :: * -> *) (f :: * -> *).
(MonadStorage m, MonadError String m, MonadIO m) =>
Identity f -> m UnifiedIdentity
mergeIdentity Identity []
cidentity
        (Maybe (Identity []), UnifiedIdentity)
-> m (Maybe (Identity []), UnifiedIdentity)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Identity [] -> Maybe (Identity [])
forall a. a -> Maybe a
Just (Identity [] -> Maybe (Identity []))
-> Identity [] -> Maybe (Identity [])
forall a b. (a -> b) -> a -> b
$ UnifiedIdentity -> Identity []
forall (m :: * -> *). Identity m -> Identity []
toComposedIdentity UnifiedIdentity
identity, UnifiedIdentity
identity)
    Maybe (Identity [])
Nothing -> String -> m (Maybe (Identity []), UnifiedIdentity)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no existing shared identity"

updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m ()
updateSharedIdentity :: forall (m :: * -> *).
(MonadHead LocalState m, MonadError String m) =>
m ()
updateSharedIdentity = (Stored LocalState -> m (Stored LocalState)) -> m ()
forall a (m :: * -> *).
MonadHead a m =>
(Stored a -> m (Stored a)) -> m ()
updateLocalHead_ ((Stored LocalState -> m (Stored LocalState)) -> m ())
-> (Stored LocalState -> m (Stored LocalState)) -> m ()
forall a b. (a -> b) -> a -> b
$ (Maybe (Identity []) -> m (Maybe (Identity [])))
-> Stored LocalState -> m (Stored LocalState)
forall a (m :: * -> *).
(SharedType a, MonadHead LocalState m) =>
(a -> m a) -> Stored LocalState -> m (Stored LocalState)
updateSharedState_ ((Maybe (Identity []) -> m (Maybe (Identity [])))
 -> Stored LocalState -> m (Stored LocalState))
-> (Maybe (Identity []) -> m (Maybe (Identity [])))
-> Stored LocalState
-> m (Stored LocalState)
forall a b. (a -> b) -> a -> b
$ \case
    Just Identity []
identity -> do
        Identity [] -> Maybe (Identity [])
forall a. a -> Maybe a
Just (Identity [] -> Maybe (Identity []))
-> (UnifiedIdentity -> Identity [])
-> UnifiedIdentity
-> Maybe (Identity [])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnifiedIdentity -> Identity []
forall (m :: * -> *). Identity m -> Identity []
toComposedIdentity (UnifiedIdentity -> Maybe (Identity []))
-> m UnifiedIdentity -> m (Maybe (Identity []))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity [] -> m UnifiedIdentity
forall (f :: * -> *) (m :: * -> *).
(Foldable f, MonadStorage m, MonadIO m, MonadError String m) =>
Identity f -> m UnifiedIdentity
interactiveIdentityUpdate Identity []
identity
    Maybe (Identity [])
Nothing -> String -> m (Maybe (Identity []))
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no existing shared identity"

interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError String m) => Identity f -> m UnifiedIdentity
interactiveIdentityUpdate :: forall (f :: * -> *) (m :: * -> *).
(Foldable f, MonadStorage m, MonadIO m, MonadError String m) =>
Identity f -> m UnifiedIdentity
interactiveIdentityUpdate Identity f
identity = do
    let public :: Stored PublicKey
public = Identity f -> Stored PublicKey
forall (m :: * -> *). Identity m -> Stored PublicKey
idKeyIdentity Identity f
identity

    Text
name <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
        Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String -> Text
T.pack String
"Name" ]
            , case Identity f -> Maybe Text
forall (m :: * -> *). Identity m -> Maybe Text
idName Identity f
identity of
                   Just Text
name -> [String -> Text
T.pack String
" [", Text
name, String -> Text
T.pack String
"]"]
                   Maybe Text
Nothing -> []
            , [ String -> Text
T.pack String
": " ]
            ]
        Handle -> IO ()
hFlush Handle
stdout
        IO Text
T.getLine

    if  | Text -> Bool
T.null Text
name -> Identity f -> m UnifiedIdentity
forall (m :: * -> *) (f :: * -> *).
(MonadStorage m, MonadError String m, MonadIO m) =>
Identity f -> m UnifiedIdentity
mergeIdentity Identity f
identity
        | Bool
otherwise -> do
            SecretKey
secret <- Stored PublicKey -> m SecretKey
forall sec pub (m :: * -> *).
(KeyPair sec pub, MonadIO m, MonadError String m) =>
Stored pub -> m sec
loadKey Stored PublicKey
public
            m UnifiedIdentity
-> (UnifiedIdentity -> m UnifiedIdentity)
-> Maybe UnifiedIdentity
-> m UnifiedIdentity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m UnifiedIdentity
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"created invalid identity") UnifiedIdentity -> m UnifiedIdentity
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnifiedIdentity -> m UnifiedIdentity)
-> (Stored (Signed IdentityData) -> Maybe UnifiedIdentity)
-> Stored (Signed IdentityData)
-> m UnifiedIdentity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Signed IdentityData) -> Maybe UnifiedIdentity
validateIdentity (Stored (Signed IdentityData) -> m UnifiedIdentity)
-> m (Stored (Signed IdentityData)) -> m UnifiedIdentity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                Signed IdentityData -> m (Stored (Signed IdentityData))
forall a. Storable a => a -> m (Stored a)
forall (m :: * -> *) a.
(MonadStorage m, Storable a) =>
a -> m (Stored a)
mstore (Signed IdentityData -> m (Stored (Signed IdentityData)))
-> m (Signed IdentityData) -> m (Stored (Signed IdentityData))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SecretKey -> Stored IdentityData -> m (Signed IdentityData)
forall (m :: * -> *) a.
MonadStorage m =>
SecretKey -> Stored a -> m (Signed a)
sign SecretKey
secret (Stored IdentityData -> m (Signed IdentityData))
-> m (Stored IdentityData) -> m (Signed IdentityData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IdentityData -> m (Stored IdentityData)
forall a. Storable a => a -> m (Stored a)
forall (m :: * -> *) a.
(MonadStorage m, Storable a) =>
a -> m (Stored a)
mstore (Stored PublicKey -> IdentityData
emptyIdentityData Stored PublicKey
public)
                { iddPrev = toList $ idDataF identity
                , iddName = Just name
                }