From 88a7bb50033baab3c2d0eed7e4be868e8966300a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Fri, 17 Nov 2023 20:28:44 +0100 Subject: Split to library and executable parts --- src/Erebos/State.hs | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 199 insertions(+) create mode 100644 src/Erebos/State.hs (limited to 'src/Erebos/State.hs') diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs new file mode 100644 index 0000000..1f0bf7d --- /dev/null +++ b/src/Erebos/State.hs @@ -0,0 +1,199 @@ +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 + { lsIdentity :: Stored (Signed ExtendedIdentityData) + , lsShared :: [Stored SharedState] + } + +data SharedState = SharedState + { ssPrev :: [Stored SharedState] + , ssType :: Maybe SharedTypeID + , ssValue :: [Ref] + } + +newtype SharedTypeID = SharedTypeID UUID + deriving (Eq, Ord, StorableUUID) + +mkSharedTypeID :: String -> SharedTypeID +mkSharedTypeID = maybe (error "Invalid shared type ID") SharedTypeID . U.fromString + +class Mergeable a => SharedType a where + sharedTypeID :: proxy a -> SharedTypeID + +instance Storable LocalState where + store' st = storeRec $ do + storeRef "id" $ lsIdentity st + mapM_ (storeRef "shared") $ lsShared st + + load' = loadRec $ LocalState + <$> loadRef "id" + <*> loadRefs "shared" + +instance HeadType LocalState where + headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e" + +instance Storable SharedState where + store' st = storeRec $ do + mapM_ (storeRef "PREV") $ ssPrev st + storeMbUUID "type" $ ssType st + mapM_ (storeRawRef "value") $ ssValue st + + load' = loadRec $ SharedState + <$> loadRefs "PREV" + <*> loadMbUUID "type" + <*> loadRawRefs "value" + +instance SharedType (Maybe ComposedIdentity) where + sharedTypeID _ = mkSharedTypeID "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_ f = updateLocalHead (fmap (,()) . f) + +instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where + updateLocalHead f = do + h <- ask + snd <$> updateHead h f + + +loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState) +loadLocalStateHead st = loadHeads st >>= \case + (h:_) -> return h + [] -> liftIO $ do + putStr "Name: " + hFlush stdout + name <- T.getLine + + putStr "Device: " + hFlush stdout + devName <- T.getLine + + owner <- if + | T.null name -> return Nothing + | otherwise -> Just <$> createIdentity st (Just name) Nothing + + identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner + + shared <- wrappedStore st $ SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [storedRef $ idExtData $ fromMaybe identity owner] + } + storeHead st $ LocalState + { lsIdentity = idExtData identity + , lsShared = [shared] + } + +localIdentity :: LocalState -> UnifiedIdentity +localIdentity ls = maybe (error "failed to verify local identity") + (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) + (validateExtendedIdentity $ lsIdentity ls) + +headLocalIdentity :: Head LocalState -> UnifiedIdentity +headLocalIdentity = localIdentity . headObject + + +updateSharedState_ :: forall a m. (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState) +updateSharedState_ f = fmap fst <$> updateSharedState (fmap (,()) . f) + +updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b) +updateSharedState f = \ls -> do + let shared = lsShared $ fromStored ls + val = lookupSharedValue shared + st <- getStorage + (val', x) <- f val + (,x) <$> if toComponents val' == toComponents val + then return ls + else do shared' <- makeSharedStateUpdate st val' shared + wrappedStore st (fromStored ls) { lsShared = [shared'] } + +lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a +lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper + where helper (x:xs) | Just sid <- ssType (fromStored x), sid == sharedTypeID @a Proxy = x : helper xs + | otherwise = helper $ ssPrev (fromStored x) ++ xs + helper [] = [] + +makeSharedStateUpdate :: forall a m. MonadIO m => SharedType a => Storage -> a -> [Stored SharedState] -> m (Stored SharedState) +makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState + { ssPrev = prev + , ssType = Just $ sharedTypeID @a Proxy + , ssValue = storedRef <$> toComponents val + } + + +mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity +mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case + Just cidentity -> do + identity <- mergeIdentity cidentity + return (Just $ toComposedIdentity identity, identity) + Nothing -> throwError "no existing shared identity" + +updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m () +updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case + Just identity -> do + Just . toComposedIdentity <$> interactiveIdentityUpdate identity + Nothing -> throwError "no existing shared identity" + +interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError String m) => Identity f -> m UnifiedIdentity +interactiveIdentityUpdate identity = do + let public = idKeyIdentity identity + + name <- liftIO $ do + T.putStr $ T.concat $ concat + [ [ T.pack "Name" ] + , case idName identity of + Just name -> [T.pack " [", name, T.pack "]"] + Nothing -> [] + , [ T.pack ": " ] + ] + hFlush stdout + T.getLine + + if | T.null name -> mergeIdentity identity + | otherwise -> do + secret <- loadKey public + maybe (throwError "created invalid identity") return . validateIdentity =<< + mstore =<< sign secret =<< mstore (emptyIdentityData public) + { iddPrev = toList $ idDataF identity + , iddName = Just name + } -- cgit v1.2.3