1 files changed, 199 insertions, 0 deletions
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
+                }