Storage: typed heads

1 files changed, 61 insertions, 71 deletions

diff --git a/src/State.hs b/src/State.hs
index 15ae7d2..8e9e320 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -3,21 +3,19 @@ module State (
     SharedState, SharedType(..),
     SharedTypeID, mkSharedTypeID,
 
-    loadLocalState, loadLocalStateHead,
+    loadLocalStateHead,
     updateLocalState, updateLocalState_,
 
     updateSharedState, updateSharedState_,
     lookupSharedValue, makeSharedStateUpdate,
 
-    loadLocalIdentity, headLocalIdentity,
+    headLocalIdentity,
 
     mergeSharedIdentity,
     updateSharedIdentity,
     interactiveIdentityUpdate,
 ) where
 
-import Control.Monad
-
 import Data.Foldable
 import Data.Maybe
 import qualified Data.Text as T
@@ -62,6 +60,9 @@ instance Storable LocalState where
         <$> 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
@@ -77,80 +78,69 @@ instance SharedType (Signed IdentityData) where
     sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
 
 
-loadLocalState :: Storage -> IO (Stored LocalState)
-loadLocalState = return . wrappedLoad . headRef <=< loadLocalStateHead
-
-loadLocalStateHead :: Storage -> IO Head
-loadLocalStateHead st = loadHeadDef st "erebos" $ do
-    putStr "Name: "
-    hFlush stdout
-    name <- T.getLine
-
-    putStr "Device: "
-    hFlush stdout
-    devName <- T.getLine
-
-    (owner, secret) <- if
-        | T.null name -> return (Nothing, Nothing)
-        | otherwise -> do
-            (secret, public) <- generateKeys st
-            (_secretMsg, publicMsg) <- generateKeys st
-
-            return . (, Just secret) . Just =<< wrappedStore st =<< sign secret =<<
-                wrappedStore st (emptyIdentityData public)
-                { iddName = Just name, iddKeyMessage = Just publicMsg }
-
-    (devSecret, devPublic) <- generateKeys st
-    (_devSecretMsg, devPublicMsg) <- generateKeys st
-
-    identity <- wrappedStore st =<< maybe return signAdd secret =<< sign devSecret =<< wrappedStore st (emptyIdentityData devPublic)
-        { iddName = if T.null devName then Nothing else Just devName
-        , iddOwner = owner
-        , iddKeyMessage = Just devPublicMsg
-        }
-
-    shared <- wrappedStore st $ SharedState
-        { ssPrev = []
-        , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy
-        , ssValue = [storedRef $ fromMaybe identity owner]
-        }
-    return $ LocalState
-        { lsIdentity = identity
-        , lsShared = [shared]
-        }
-
-loadLocalIdentity :: Storage -> IO UnifiedIdentity
-loadLocalIdentity = return . headLocalIdentity <=< loadLocalStateHead
-
-headLocalIdentity :: Head -> UnifiedIdentity
+loadLocalStateHead :: Storage -> IO (Head LocalState)
+loadLocalStateHead st = loadHeads st >>= \case
+    (h:_) -> return h
+    [] -> do
+        putStr "Name: "
+        hFlush stdout
+        name <- T.getLine
+
+        putStr "Device: "
+        hFlush stdout
+        devName <- T.getLine
+
+        (owner, secret) <- if
+            | T.null name -> return (Nothing, Nothing)
+            | otherwise -> do
+                (secret, public) <- generateKeys st
+                (_secretMsg, publicMsg) <- generateKeys st
+
+                return . (, Just secret) . Just =<< wrappedStore st =<< sign secret =<<
+                    wrappedStore st (emptyIdentityData public)
+                    { iddName = Just name, iddKeyMessage = Just publicMsg }
+
+        (devSecret, devPublic) <- generateKeys st
+        (_devSecretMsg, devPublicMsg) <- generateKeys st
+
+        identity <- wrappedStore st =<< maybe return signAdd secret =<< sign devSecret =<< wrappedStore st (emptyIdentityData devPublic)
+            { iddName = if T.null devName then Nothing else Just devName
+            , iddOwner = owner
+            , iddKeyMessage = Just devPublicMsg
+            }
+
+        shared <- wrappedStore st $ SharedState
+            { ssPrev = []
+            , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy
+            , ssValue = [storedRef $ fromMaybe identity owner]
+            }
+        storeHead st $ LocalState
+            { lsIdentity = identity
+            , lsShared = [shared]
+            }
+
+headLocalIdentity :: Head LocalState -> UnifiedIdentity
 headLocalIdentity h =
-    let ls = load $ headRef h
+    let ls = headObject h
      in maybe (error "failed to verify local identity")
             (updateOwners (lookupSharedValue $ lsShared ls))
             (validateIdentity $ lsIdentity ls)
 
 
-updateLocalState_ :: Storage -> (Stored LocalState -> IO (Stored LocalState)) -> IO ()
-updateLocalState_ st f = updateLocalState st (fmap (,()) . f)
-
-updateLocalState :: Storage -> (Stored LocalState -> IO (Stored LocalState, a)) -> IO a
-updateLocalState st f = do
-    Just erebosHead <- loadHead st "erebos"
-    let ls = wrappedLoad (headRef erebosHead)
-    (ls', x) <- f ls
-    when (ls' /= ls) $ do
-        Right _ <- replaceHead ls' (Right erebosHead)
-        return ()
-    return x
+updateLocalState_ :: Head LocalState -> (Stored LocalState -> IO (Stored LocalState)) -> IO ()
+updateLocalState_ h f = updateLocalState h (fmap (,()) . f)
 
+updateLocalState :: Head LocalState -> (Stored LocalState -> IO (Stored LocalState, a)) -> IO a
+updateLocalState h f = snd <$> updateHead h f
 
-updateSharedState_ :: SharedType a => Storage -> ([Stored a] -> IO ([Stored a])) -> IO ()
-updateSharedState_ st f = updateSharedState st (fmap (,()) . f)
+updateSharedState_ :: SharedType a => Head LocalState -> ([Stored a] -> IO ([Stored a])) -> IO ()
+updateSharedState_ h f = updateSharedState h (fmap (,()) . f)
 
-updateSharedState :: forall a b. SharedType a => Storage -> ([Stored a] -> IO ([Stored a], b)) -> IO b
-updateSharedState st f = updateLocalState st $ \ls -> do
+updateSharedState :: forall a b. SharedType a => Head LocalState -> ([Stored a] -> IO ([Stored a], b)) -> IO b
+updateSharedState h f = updateLocalState h $ \ls -> do
     let shared = lsShared $ fromStored ls
         val = lookupSharedValue shared
+        st = refStorage $ headRef h
     (val', x) <- f val
     (,x) <$> if val' == val
                 then return ls
@@ -171,14 +161,14 @@ makeSharedStateUpdate st val prev = wrappedStore st SharedState
     }
 
 
-mergeSharedIdentity :: Storage -> IO UnifiedIdentity
-mergeSharedIdentity st = updateSharedState st $ \sdata -> do
+mergeSharedIdentity :: Head LocalState -> IO UnifiedIdentity
+mergeSharedIdentity = flip updateSharedState $ \sdata -> do
     let Just cidentity = validateIdentityF sdata
     identity <- mergeIdentity cidentity
     return ([idData identity], identity)
 
-updateSharedIdentity :: Storage -> IO ()
-updateSharedIdentity st = updateSharedState_ st $ \sdata -> do
+updateSharedIdentity :: Head LocalState -> IO ()
+updateSharedIdentity = flip updateSharedState_ $ \sdata -> do
     let Just identity = validateIdentityF sdata
     (:[]) . idData <$> interactiveIdentityUpdate identity