Split to library and executable parts

1 files changed, 0 insertions, 199 deletions

diff --git a/src/State.hs b/src/State.hs
deleted file mode 100644
index e1ddcea..0000000
--- a/src/State.hs
+++ /dev/null
@@ -1,199 +0,0 @@
-module 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 Identity
-import PubKey
-import Storage
-import 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
-                }