summaryrefslogtreecommitdiff
path: root/src/State.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/State.hs')
-rw-r--r--src/State.hs132
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 20:23:31 +0000