From 558e691ae44acbb3de3ab2100416b5d3bbfb7c44 Mon Sep 17 00:00:00 2001 From: prolic Date: Fri, 13 Sep 2024 20:40:33 -0400 Subject: [PATCH] finish up effectful key mgmt --- cabal.project | 5 +- futr.cabal | 4 +- src/EffectfulQML.hs | 41 +++ src/Main.hs | 63 +++-- src/Presentation/KeyMgmt.hs | 485 ++++++++++++++++++++---------------- src/QMLEffectful.hs | 52 ---- src/Types.hs | 11 +- 7 files changed, 352 insertions(+), 309 deletions(-) create mode 100644 src/EffectfulQML.hs delete mode 100644 src/QMLEffectful.hs diff --git a/cabal.project b/cabal.project index 9c489f8..ba81d76 100755 --- a/cabal.project +++ b/cabal.project @@ -1,11 +1,8 @@ packages: + /home/sasa/code/HsQML/ ./ tests: True -source-repository-package - type: git - location: https://github.com/prolic/HsQML/ - tag: e7fe83f9cc535c66c423d5402d3351c774a5bc2c source-repository-package type: git diff --git a/futr.cabal b/futr.cabal index cbef9ce..ebca663 100755 --- a/futr.cabal +++ b/futr.cabal @@ -1,4 +1,4 @@ -cabal-version: 3.12 +cabal-version: 2.4 name: futr version: 0.1.0.0 license: GPL-3.0-only @@ -29,6 +29,7 @@ executable futr hs-source-dirs: src other-modules: + EffectfulQML Nostr.Effects.IDGen Nostr.Effects.Logging Nostr.Effects.RelayPool @@ -43,7 +44,6 @@ executable futr Nostr.Relay Nostr.Types Presentation.KeyMgmt - QMLEffectful Types default-language: Haskell2010 diff --git a/src/EffectfulQML.hs b/src/EffectfulQML.hs new file mode 100644 index 0000000..97a5b8f --- /dev/null +++ b/src/EffectfulQML.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module EffectfulQML where + +import Data.Typeable +import Effectful +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get) +import Effectful.TH +import Graphics.QML hiding (fireSignal, runEngineLoop) +import Graphics.QML qualified as QML + +-- | Data type to hold a signal key and object reference +data SignalUpdate + = forall tt. + ( Typeable tt + ) => + SignalUpdate + { signalKey :: SignalKey (IO ()), + object :: ObjRef tt + } + +-- | Define the effects for QML operations. +data EffectfulQML :: Effect where + RunEngineLoop :: EngineConfig -> EffectfulQML m () + FireSignal :: EffectfulQML m () + +type instance DispatchOf EffectfulQML = Dynamic + +makeEffect ''EffectfulQML + +-- | Handler for the QML effects. +runEffectfulQML :: (IOE :> es, State SignalUpdate :> es) => Eff (EffectfulQML : es) a -> Eff es a +runEffectfulQML = interpret $ \_ -> \case + RunEngineLoop config -> do + liftIO $ QML.runEngineLoop config + FireSignal -> do + SignalUpdate key obj <- get + liftIO $ QML.fireSignal key obj diff --git a/src/Main.hs b/src/Main.hs index 4512d3d..d138f18 100755 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,71 +1,58 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Main where import Control.Concurrent (MVar, modifyMVar_, newMVar, readMVar) import qualified Data.Map as Map import Data.Text (pack, unpack) import Data.Typeable (Typeable) -import Graphics.QML +import Effectful +import Effectful.State.Static.Shared (State, evalState, execState, runState) +import Graphics.QML qualified as QML import System.Environment (setEnv) import Text.Read (readMaybe) import Nostr.Keys (KeyPair, secKeyToKeyPair) import Presentation.KeyMgmt +import QMLEffectful import Types -data AppModel = AppModel - { keyPair :: Maybe KeyPair - , currentScreen :: AppScreen - , keyMgmtModel :: MVar KeyMgmtModel - } deriving (Typeable) - -createContext :: MVar AppModel -> SignalKey (IO ()) -> IO (ObjRef ()) +createContext :: SignalKey (IO ()) -> IO (QML.ObjRef ()) createContext modelVar changeKey = do - let getKeyPair' :: IO (Maybe KeyPair) - getKeyPair' = do - appModel' <- readMVar modelVar - return (keyPair appModel') - - setKeyPair' :: KeyPair -> IO () - setKeyPair' kp = modifyMVar_ modelVar $ \m -> return m { keyPair = Just kp } + appModel <- readMVar modelVar - keyMgmtObj <- createKeyMgmtCtx (keyMgmtModel appModel) changeKey getKeyPair' setKeyPair' + keyMgmtObj <- createKeyMgmtCtx (keyMgmtModel appModel) changeKey - rootClass <- newClass [ - defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj), + rootClass <- QML.newClass [ + QML.defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj), - defPropertySigRW' "currentScreen" changeKey + QML.defPropertySigRW' "currentScreen" changeKey (\_ -> fmap (pack . show . currentScreen) (readMVar modelVar)) (\obj newScreen -> do case readMaybe (unpack newScreen) :: Maybe AppScreen of Just s -> do modifyMVar_ modelVar $ \model -> return model { currentScreen = s } - fireSignal changeKey obj + QML.fireSignal changeKey obj Nothing -> return ()), - defMethod' "login" $ \this input -> do + QML.defMethod' "login" $ \this input -> do appModel' <- readMVar modelVar keyMgmtModel' <- readMVar $ keyMgmtModel appModel' case Map.lookup (AccountId input) (accountMap keyMgmtModel') of Just a -> do modifyMVar_ modelVar $ \m -> return m { keyPair = Just $ secKeyToKeyPair $ nsec a, currentScreen = Home } - fireSignal changeKey this + QML.fireSignal changeKey this Nothing -> return () ] - rootObj <- newObject rootClass () + rootObj <- QML.newObject rootClass () return rootObj main :: IO () main = do accounts <- listAccounts - keyMgmtM <- newMVar $ KeyMgmtModel accounts "" "" + keyMgmtM <- newMVar $ KeyMgmtModel accounts "" "" "" "" let appModel = AppModel { keyPair = Nothing @@ -74,7 +61,7 @@ main = do } modelVar <- newMVar appModel - changeKey <- newSignalKey :: IO (SignalKey (IO ())) + changeKey <- QML.newSignalKey :: IO (QML.SignalKey (IO ())) ctx <- createContext modelVar changeKey let path = "qrc:/qml/main.qml" @@ -88,9 +75,15 @@ main = do setEnv "QT_LOGGING_RULES" "qt.qml.connections=false" setEnv "QT_ENABLE_HIGHDPI_SCALING" "1" - runEngineLoop defaultEngineConfig - { initialDocument = fileDocument path - , contextObject = Just $ anyObjRef ctx - , importPaths = [importPath, importPath', importPath''] - , iconPath = Just ":/icons/nostr-purple.png" - } + let config = QML.defaultEngineConfig + { QML.initialDocument = QML.fileDocument path + , QML.contextObject = Just $ QML.anyObjRef ctx + , QML.importPaths = [importPath, importPath', importPath''] + , QML.iconPath = Just ":/icons/nostr-purple.png" + } + + let signalUpdate = SignalUpdate changeKey ctx + + runEff $ evalState signalUpdate $ runQMLEffectful $ do + + runEngineLoop config \ No newline at end of file diff --git a/src/Presentation/KeyMgmt.hs b/src/Presentation/KeyMgmt.hs index fc2a823..7bfcba0 100644 --- a/src/Presentation/KeyMgmt.hs +++ b/src/Presentation/KeyMgmt.hs @@ -1,241 +1,302 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications, TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Presentation.KeyMgmt where -import Control.Concurrent (MVar, modifyMVar_, readMVar) import Control.Monad (filterM) -import Data.Aeson (FromJSON(..), eitherDecode) -import qualified Data.ByteString.Lazy as BL -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Aeson (FromJSON (..), eitherDecode) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text, isPrefixOf, pack, strip, unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable (Typeable) -import qualified Data.Text.IO as TIO -import Graphics.QML -import System.Directory (XdgDirectory(XdgData), createDirectoryIfMissing, - getXdgDirectory, listDirectory, doesDirectoryExist, - doesFileExist, removeDirectoryRecursive) -import System.FilePath ((), takeFileName) -import Text.Read (readMaybe) - -import Nostr.Keys hiding (getKeyPair) +import Effectful +import Effectful.Dispatch.Dynamic (EffectHandler, interpret) +import Effectful.FileSystem + ( FileSystem, + XdgDirectory (XdgData), + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + getXdgDirectory, + listDirectory, + removeDirectoryRecursive, + ) +import Effectful.FileSystem.IO.ByteString qualified as FIOE (readFile, writeFile) +import Effectful.FileSystem.IO.ByteString.Lazy qualified as BL +import Effectful.State.Static.Shared (State, get, modify) +import Effectful.TH +import EffectfulQML +import Graphics.QML hiding (fireSignal, runEngineLoop) +import Nostr.Keys import Nostr.Relay (defaultRelays) import Nostr.Types +import System.FilePath (takeFileName, ()) +import Text.Read (readMaybe) data Account = Account - { nsec :: SecKey - , npub :: PubKeyXO - , relays :: [(RelayURI, RelayInfo)] - , displayName :: Text - , picture :: Text - } deriving (Eq, Show) + { nsec :: SecKey, + npub :: PubKeyXO, + relays :: [(RelayURI, RelayInfo)], + displayName :: Text, + picture :: Text + } + deriving (Eq, Show) newtype AccountId = AccountId {accountId :: Text} deriving (Eq, Ord, Show, Typeable) -data KeyMgmtModel = KeyMgmtModel - { accountMap :: Map AccountId Account - , seedphrase :: Text - , errorMsg :: Text +data KeyMgmtState = KeyMgmtState + { accountMap :: Map AccountId Account, + accountPool :: Maybe (FactoryPool AccountId), + seedphrase :: Text, + npubView :: Text, + nsecView :: Text, + errorMsg :: Text + } + +initialState :: KeyMgmtState +initialState = + KeyMgmtState + { accountMap = Map.empty, + accountPool = Nothing, + seedphrase = "", + npubView = "", + nsecView = "", + errorMsg = "" } -importSecretKey :: Text -> IO (Maybe KeyPair) -importSecretKey input = do - let skMaybe = if "nsec" `isPrefixOf` input - then bech32ToSecKey input - else readMaybe (unpack input) :: Maybe SecKey - case skMaybe of - Just sk -> do - storageDir <- getXdgDirectory XdgData $ "futrnostr/" ++ (unpack $ pubKeyXOToBech32 pk) - _ <- createDirectoryIfMissing True storageDir - _ <- TIO.writeFile (storageDir ++ "/nsec") (secKeyToBech32 sk) - return $ Just kp - where - pk = derivePublicKeyXO sk - kp = secKeyToKeyPair sk - Nothing -> - return Nothing - -listAccounts :: IO (Map AccountId Account) -listAccounts = do +-- | Key Management Effects. +data KeyMgmt :: Effect where + LoadAccounts :: KeyMgmt m () + ImportSecretKey :: Text -> KeyMgmt m () + ImportSeedphrase :: Text -> Text -> KeyMgmt m () + GenerateSeedphrase :: KeyMgmt m () + RemoveAccount :: Text -> KeyMgmt m () + +type instance DispatchOf KeyMgmt = Dynamic + +makeEffect ''KeyMgmt + +-- | Key Management Effect for creating QML context. +data KeyMgmtContext :: Effect where + CreateCtx :: KeyMgmtContext m (ObjRef ()) + +type instance DispatchOf KeyMgmtContext = Dynamic + +makeEffect ''KeyMgmtContext + +-- | Handler for the logging effect to stdout. +runKeyMgmt :: (FileSystem :> es, IOE :> es, State KeyMgmtState :> es, EffectfulQML :> es) => Eff (KeyMgmt : es) a -> Eff es a +runKeyMgmt = interpret $ \_ -> \case + LoadAccounts -> do storageDir <- getXdgDirectory XdgData "futrnostr" directoryExists <- doesDirectoryExist storageDir if directoryExists - then do - contents <- listDirectory storageDir - npubDirs <- filterM (isNpubDirectory storageDir) contents - accounts <- mapM (loadAccount storageDir) npubDirs - let accountPairs = catMaybes $ zipWith (\dir acc -> fmap (\a -> (AccountId $ pack dir, a)) acc) npubDirs accounts - return $ Map.fromList accountPairs - else return Map.empty - -removeAccount:: Text -> IO () -removeAccount a = do - dir <- getXdgDirectory XdgData $ "futrnostr/" ++ (unpack a) + then do + contents <- listDirectory storageDir + npubDirs <- filterM (isNpubDirectory storageDir) contents + accounts <- mapM (loadAccount storageDir) npubDirs + let accountPairs = catMaybes $ zipWith (\dir acc -> fmap (\a -> (AccountId $ pack dir, a)) acc) npubDirs accounts + modify $ \st -> st {accountMap = Map.fromList accountPairs} + else modify $ \st -> st {accountMap = Map.empty} + fireSignal + + ImportSecretKey input -> do + mkp <- tryImportSecretKeyAndPersist input + case mkp of + Just kp -> do + let (ai, ad) = accountFromKeyPair kp + modify $ \st -> st {accountMap = Map.insert ai ad (accountMap st)} + Nothing -> do + modify $ \st -> st {errorMsg = "Error: Importing secret key failed"} + fireSignal + + ImportSeedphrase input pwd -> do + mkp <- liftIO $ mnemonicToKeyPair input pwd + case mkp of + Right kp -> do + let secKey = keyPairToSecKey kp + tryImportSecretKeyAndPersist (secKeyToBech32 secKey) >>= \mkp' -> + case mkp' of + Just _ -> do + let (ai, ad) = accountFromKeyPair kp + modify $ \st -> st {accountMap = Map.insert ai ad (accountMap st)} + Nothing -> modify $ \st -> st {errorMsg = "Error: Seedphrase generation failed"} + Left err -> modify $ \st -> st {errorMsg = "Error: " <> pack err} + fireSignal + + GenerateSeedphrase -> do + mnemonicResult <- liftIO createMnemonic + case mnemonicResult of + Left err -> modify $ \st -> st {errorMsg = "Error: " <> pack err} + Right m' -> do + keyPairResult <- liftIO $ mnemonicToKeyPair m' "" + case keyPairResult of + Left err' -> modify $ \st -> st {errorMsg = "Error: " <> pack err'} + Right mkp' -> do + let secKey = keyPairToSecKey mkp' + maybeKeyPair <- tryImportSecretKeyAndPersist (secKeyToBech32 secKey) + case maybeKeyPair of + Just kp -> do + let (ai, ad) = accountFromKeyPair kp + modify $ \st -> + st + { accountMap = Map.insert ai ad (accountMap st), + seedphrase = m', + nsecView = secKeyToBech32 $ keyPairToSecKey kp, + npubView = pubKeyXOToBech32 $ keyPairToPubKeyXO kp + } + Nothing -> modify $ \st -> st {errorMsg = "Error: Unknown error generating new keys"} + fireSignal + + RemoveAccount input -> do + modify $ \st -> st {accountMap = Map.delete (AccountId input) (accountMap st)} + fireSignal + dir <- getXdgDirectory XdgData $ "futrnostr/" ++ (unpack input) directoryExists <- doesDirectoryExist dir if directoryExists - then removeDirectoryRecursive dir - else return () + then removeDirectoryRecursive dir + else return () -isNpubDirectory :: FilePath -> FilePath -> IO Bool +runKeyMgmtContext :: + (KeyMgmt :> es, State KeyMgmtState :> es, IOE :> es, EffectfulQML :> es) => + SignalKey (IO ()) -> + Eff (KeyMgmtContext : es) a -> + Eff es a +runKeyMgmtContext changeKey action = interpret handleKeyMgmtContext action + where + handleKeyMgmtContext :: (KeyMgmt :> es, State KeyMgmtState :> es, IOE :> es, EffectfulQML :> es) => EffectHandler KeyMgmtContext es + handleKeyMgmtContext _ = \case + CreateCtx -> withRunInIO $ \runE -> do + let prop n f = + defPropertySigRO' + n + changeKey + ( \obj -> runE $ do + st <- get + let res = maybe "" f $ Map.lookup (fromObjRef obj) (accountMap st) + fireSignal + return res + ) + + accountClass <- + newClass + [ prop "nsec" (secKeyToBech32 . nsec), + prop "npub" (pubKeyXOToBech32 . npub), + prop "displayName" displayName, + prop "picture" picture + ] + + accountPool' <- newFactoryPool (newObject accountClass) + + runE $ modify $ \st -> st {accountPool = Just accountPool'} + + contextClass <- + newClass + [ defPropertySigRO' "accounts" changeKey $ \_ -> do + st <- runE get + runE fireSignal + mapM (getPoolObject accountPool') $ Map.keys (accountMap st), + defMethod' "removeAccount" $ \_ input -> runE $ removeAccount input, + defPropertySigRO' "seedphrase" changeKey $ \_ -> do + st <- runE get + return $ seedphrase st, + defPropertySigRO' "nsec" changeKey $ \_ -> do + st <- runE get + return $ nsecView st, + defPropertySigRO' "npub" changeKey $ \_ -> do + st <- runE get + return $ npubView st, + defPropertySigRW' + "errorMsg" + changeKey + ( \_ -> do + st <- runE get + return $ errorMsg st + ) + ( \_ newErrorMsg -> runE $ do + modify $ \st -> st {errorMsg = newErrorMsg} + fireSignal + return () + ), + defMethod' "importSecretKey" $ \_ (input :: Text) -> runE $ importSecretKey input, + defMethod' "importSeedphrase" $ \_ input pwd -> runE $ importSeedphrase input pwd, + defMethod' "generateSeedphrase" $ \_ -> runE $ generateSeedphrase + ] + + newObject contextClass () + +tryImportSecretKeyAndPersist :: (FileSystem :> es) => Text -> Eff es (Maybe KeyPair) +tryImportSecretKeyAndPersist input = do + let skMaybe = + if "nsec" `isPrefixOf` input + then bech32ToSecKey input + else readMaybe (unpack input) :: Maybe SecKey + case skMaybe of + Just sk -> do + storageDir <- getXdgDirectory XdgData $ "futrnostr/" ++ (unpack $ pubKeyXOToBech32 pk) + createDirectoryIfMissing True storageDir + FIOE.writeFile (storageDir ++ "/nsec") (encodeUtf8 $ secKeyToBech32 sk) + return $ Just kp + where + pk = derivePublicKeyXO sk + kp = secKeyToKeyPair sk + Nothing -> + return Nothing + +isNpubDirectory :: (FileSystem :> es) => FilePath -> FilePath -> Eff es Bool isNpubDirectory storageDir name = do - let fullPath = storageDir name - isDir <- doesDirectoryExist fullPath - let fileName = takeFileName fullPath - return $ isDir && "npub" `isPrefixOf` pack fileName + let fullPath = storageDir name + isDir <- doesDirectoryExist fullPath + let fileName = takeFileName fullPath + return $ isDir && "npub" `isPrefixOf` pack fileName -loadAccount :: FilePath -> FilePath -> IO (Maybe Account) +loadAccount :: (FileSystem :> es) => FilePath -> FilePath -> Eff es (Maybe Account) loadAccount storageDir npubDir = do - let dirPath = storageDir npubDir - nsecContent <- readFileMaybe (dirPath "nsec") - relayList <- readJSONFile (dirPath "relays.json") - profile <- readJSONFile (dirPath "profile.json") - - return $ do - nsecKey <- bech32ToSecKey . strip =<< nsecContent - pubKeyXO <- bech32ToPubKeyXO (pack npubDir) - - Just Account - { nsec = nsecKey - , npub = pubKeyXO - , relays = fromMaybe defaultRelays relayList - , displayName = maybe "" id (profile >>= \(Profile _ d _ _ _ _) -> d) - , picture = maybe ("https://robohash.org/" <> pack npubDir <> ".png") id (profile >>= \(Profile _ _ _ p _ _) -> p) - } - -readFileMaybe :: FilePath -> IO (Maybe Text) + let dirPath = storageDir npubDir + nsecContent <- readFileMaybe (dirPath "nsec") + relayList <- readJSONFile (dirPath "relays.json") + profile <- readJSONFile (dirPath "profile.json") + + return $ do + nsecKey <- bech32ToSecKey . strip =<< nsecContent + pubKeyXO <- bech32ToPubKeyXO (pack npubDir) + + Just + Account + { nsec = nsecKey, + npub = pubKeyXO, + relays = fromMaybe defaultRelays relayList, + displayName = maybe "" id (profile >>= \(Profile _ d _ _ _ _) -> d), + picture = maybe ("https://robohash.org/" <> pack npubDir <> ".png") id (profile >>= \(Profile _ _ _ p _ _) -> p) + } + +readFileMaybe :: (FileSystem :> es) => FilePath -> Eff es (Maybe Text) readFileMaybe path = do - exists <- doesFileExist path - if exists - then Just <$> TIO.readFile path - else return Nothing + exists <- doesFileExist path + if exists + then Just <$> decodeUtf8 <$> FIOE.readFile path + else return Nothing -readJSONFile :: FromJSON a => FilePath -> IO (Maybe a) +readJSONFile :: (FromJSON a, FileSystem :> es) => FilePath -> Eff es (Maybe a) readJSONFile path = do - exists <- doesFileExist path - if exists - then eitherDecode <$> BL.readFile path >>= return . either (const Nothing) Just - else return Nothing - -addNewAccount :: MVar KeyMgmtModel -> KeyPair -> IO (Maybe Text) -addNewAccount modelVar kp = do - let newNpub = pubKeyXOToBech32 $ keyPairToPubKeyXO kp - let newAccountId = AccountId newNpub - let newAccount = Account - { nsec = keyPairToSecKey kp - , npub = keyPairToPubKeyXO kp - , relays = defaultRelays - , displayName = "" - , picture = pack "https://robohash.org/" <> newNpub <> pack ".png" - } - modifyMVar_ modelVar $ \m -> - return m { seedphrase = "", errorMsg = "", accountMap = Map.insert newAccountId newAccount (accountMap m) } - return $ Just newNpub - -createKeyMgmtCtx - :: MVar KeyMgmtModel - -> SignalKey (IO ()) - -> IO (Maybe KeyPair) - -> (KeyPair -> IO ()) - -> IO (ObjRef ()) -createKeyMgmtCtx modelVar changeKey getKeyPair setKeyPair = do - let handleError :: ObjRef() -> String -> IO () - handleError obj err = do - modifyMVar_ modelVar $ \m -> return m { errorMsg = pack err } - fireSignal changeKey obj - - let prop n f = defPropertySigRO' n changeKey (\obj -> do - model <- readMVar modelVar - return $ maybe "" f $ Map.lookup (fromObjRef obj) (accountMap model)) - - accountClass <- newClass [ - prop "nsec" (secKeyToBech32 . nsec), - prop "npub" (pubKeyXOToBech32 . npub), - prop "displayName" displayName, - prop "picture" picture - ] - - accountPool <- newFactoryPool (newObject accountClass) - - contextClass <- newClass [ - defPropertySigRO' "accounts" changeKey $ \_ -> do - model <- readMVar modelVar - mapM (getPoolObject accountPool) $ Map.keys (accountMap model), - - defMethod' "removeAccount" $ \this input -> do - modifyMVar_ modelVar $ \m -> do - let updatedMap = Map.delete (AccountId input) (accountMap m) - return m { accountMap = updatedMap } - removeAccount input - fireSignal changeKey this, - - defPropertySigRO' "seedphrase" changeKey $ \_ -> fmap seedphrase (readMVar modelVar), - - defPropertySigRW' "errorMsg" changeKey - (\_ -> fmap errorMsg (readMVar modelVar)) - (\obj newErrorMsg -> handleError obj $ unpack newErrorMsg), - - defPropertySigRO' "nsec" changeKey $ \_ -> do - mkp <- getKeyPair - case mkp of - Just kp -> return $ secKeyToBech32 (keyPairToSecKey kp) - Nothing -> return $ pack "", - - defPropertySigRO' "npub" changeKey $ \_ -> do - mkp <- getKeyPair - case mkp of - Just kp -> return $ pubKeyXOToBech32 (keyPairToPubKeyXO kp) - Nothing -> return $ pack "", - - defMethod' "importSecretKey" $ \this (input :: Text) -> do - mkp <- importSecretKey input - case mkp of - Just kp -> do - newNpub <- addNewAccount modelVar kp - fireSignal changeKey this - return newNpub - Nothing -> do - handleError this "Error: Importing secret key failed" - return Nothing, - - defMethod' "importSeedphrase" $ \this input pwd -> do - mkp <- mnemonicToKeyPair input pwd - case mkp of - Right kp -> do - let secKey = keyPairToSecKey kp - importSecretKey (secKeyToBech32 secKey) >>= \mkp' -> - case mkp' of - Just _ -> do - newNpub <- addNewAccount modelVar kp - fireSignal changeKey this - return newNpub - Nothing -> do - handleError this "Unknown error" - return Nothing - Left err -> do - handleError this err - return Nothing, - - defMethod' "generateSeedphrase" $ \this -> do - createMnemonic >>= either (\err -> handleError this err >> return Nothing) (\m' -> do - mnemonicToKeyPair m' "" >>= either (\err -> handleError this err >> return Nothing) (\mkp' -> do - let secKey = keyPairToSecKey mkp' - importSecretKey (secKeyToBech32 secKey) >>= \mkp -> - case mkp of - Just kp -> do - newNpub <- addNewAccount modelVar kp - setKeyPair kp - modifyMVar_ modelVar $ \m -> return m { seedphrase = m' } - fireSignal changeKey this - return newNpub - Nothing -> do - handleError this "Unknown error generating new keys" - return Nothing - ) - ) - - ] + exists <- doesFileExist path + if exists + then eitherDecode <$> BL.readFile path >>= return . either (const Nothing) Just + else return Nothing - newObject contextClass () - \ No newline at end of file +accountFromKeyPair :: KeyPair -> (AccountId, Account) +accountFromKeyPair kp = (AccountId newNpub, account) + where + newNpub = pubKeyXOToBech32 $ keyPairToPubKeyXO kp + account = + Account + { nsec = keyPairToSecKey kp, + npub = keyPairToPubKeyXO kp, + relays = defaultRelays, + displayName = "", + picture = pack "https://robohash.org/" <> newNpub <> pack ".png" + } diff --git a/src/QMLEffectful.hs b/src/QMLEffectful.hs deleted file mode 100644 index 7c2e193..0000000 --- a/src/QMLEffectful.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} - -module QMLEffectful where - -import Data.Typeable -import Effectful -import Effectful.Dispatch.Dynamic (interpret) -import Effectful.State.Static.Shared (State, get, put) -import Effectful.TH -import Graphics.QML qualified as QML - --- | Data type to hold a signal key and object reference -data SignalUpdate = forall tt. - ( QML.Marshal tt - , QML.CanPassTo tt ~ QML.Yes - , QML.IsObjType tt ~ QML.Yes - , Typeable tt - ) => SignalUpdate - { signalKey :: QML.SignalKey (IO ()) - , object :: QML.ObjRef tt - } - --- | Define the effects for QML operations. -data QMLEffectful :: Effect where - RunEngineLoop :: QML.EngineConfig -> SignalUpdate -> QMLEffectful m () - FireUI :: QMLEffectful m () - NewObject :: QML.Class tt -> tt -> QMLEffectful m (QML.ObjRef tt) - NewObjectDC :: QML.DefaultClass tt => tt -> QMLEffectful m (QML.ObjRef tt) - NewClass :: Typeable tt => [QML.Member tt] -> QMLEffectful m (QML.Class tt) - NewSignalKey :: (QML.SignalSuffix p) => QMLEffectful m (QML.SignalKey p) - -type instance DispatchOf QMLEffectful = Dynamic - -makeEffect ''QMLEffectful - --- | Handler for the QML effects. -runQMLEffectful :: (IOE :> es, State SignalUpdate :> es) - => Eff (QMLEffectful : es) a -> Eff es a -runQMLEffectful = interpret $ \_ -> \case - RunEngineLoop config signalUpdate -> do - put signalUpdate - liftIO $ QML.runEngineLoop config - FireUI -> do - SignalUpdate key obj <- get - liftIO $ QML.fireSignal key obj - return () - NewObject cl obj -> liftIO $ QML.newObject cl obj - NewObjectDC obj -> liftIO $ QML.newObjectDC obj - NewClass ms -> liftIO $ QML.newClass ms - NewSignalKey -> liftIO $ QML.newSignalKey diff --git a/src/Types.hs b/src/Types.hs index 4238b19..eb9f95d 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Types where +import Nostr.Keys (KeyPair) + data AppScreen = KeyMgmt | Relay | Home deriving (Eq, Read, Show) + +data Futr = Futr + { keyPair :: Maybe KeyPair + , currentScreen :: AppScreen + }