Merge pull request #24 from futrnostr/effectful

Effectful

futr.cabal

@@ -1,12 +1,12 @@
-cabal-version:      3.12
+cabal-version:      2.4
 name:               futr
 version:            0.1.0.0
 license:            GPL-3.0-only
 license-file:       LICENSE
 copyright:          2024 Sascha-Oliver Prolic
 maintainer:         [email protected]
 author:             Sascha-Oliver Prolic
-tested-with:        ghc ==9.4.8
+tested-with:        ghc == 9.4.8
 homepage:           https://github.com/futrnostr/futr#readme
 synopsis:           nostr client application
 description:        A nostr client application written in Haskell and Qt5.
@@ -29,27 +29,39 @@ executable futr
     hs-source-dirs:   src
 
     other-modules:
+        EffectfulQML
+        Futr
+        Nostr.Effects.IDGen
+        Nostr.Effects.Logging
+        Nostr.Effects.RelayPool
+        Nostr.Effects.ResponseProcessor
+        Nostr.Effects.WebSocket
         Nostr.Encryption
         Nostr.Encryption.Internal
         Nostr.Event
-        Nostr.Filter
         Nostr.Keys
         Nostr.Kind
         Nostr.Profile
         Nostr.Relay
-        Nostr.RelayPool
-        Nostr.Request
-        Nostr.Response
+        Nostr.Types
         Presentation.KeyMgmt
-        Types
 
     default-language: Haskell2010
     extra-libraries:  secp256k1
     extra-lib-dirs:   /usr/local/lib
     ghc-options:
         -threaded -Wall -Wcompat -Wincomplete-uni-patterns
         -Wincomplete-record-updates
-
+    default-extensions: DataKinds,
+                        FlexibleContexts,
+                        GADTs,
+                        ImportQualifiedPost,
+                        KindSignatures,
+                        OverloadedStrings,
+                        ScopedTypeVariables,
+                        TypeApplications,
+                        TypeFamilies,
+                        TypeOperators
     build-depends:
         aeson >=2.2.3.0 && <2.3,
         base >=4.17.2.1 && <4.18,
@@ -65,6 +77,9 @@ executable futr
         crypton >=1.0 && <1.1,
         data-default >=0.7.1.1 && <0.8,
         directory >=1.3.7.1 && <1.4,
+        effectful >=2.3.1.0 && <2.4,
+        effectful-core >=2.3.1.0 && <2.4,
+        effectful-th >=1.0.0.2 && <1.1,
         entropy >=0.4.1.10 && <0.5,
         filepath >= 1.4.2 && <1.5,
         haskoin-core >=1.1.0 && <1.2,
@@ -76,11 +91,14 @@ executable futr
         random >=1.2.1.2 && <1.3,
         secp256k1-haskell >=1.4.0 && <1.5,
         stm >=2.5.1.0 && <2.6,
-        string-conversions >= 0.4.0.1 && < 0.5,
+        string-conversions >=0.4.0.1 && <0.5,
+        tagged >=0.8.8 && <0.9,
         text >=2.0.2 && <2.1,
         time >=1.12.2 && <1.13,
         vector >=0.13.1.0 && <0.14,
-        wreq >= 0.5.4.3 && < 0.6
+        websockets >=0.13.0.0 && <0.14,
+        wreq >=0.5.4.3 && <0.6,
+        wuss >=2.0.1.8 && <2.0.1.9
 
 test-suite futr-tests
     type:                 exitcode-stdio-1.0

src/EffectfulQML.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module EffectfulQML where
+
+import Effectful
+import Effectful.Dispatch.Dynamic (EffectHandler, interpret)
+import Effectful.State.Static.Shared (State, evalState, get, put)
+import Effectful.TH
+import Graphics.QML qualified as QML
+
+data EffectfulQMLState = EffectfulQMLState
+  { signalKey :: Maybe (QML.SignalKey (IO ()))
+  }
+
+initialState :: EffectfulQMLState
+initialState = EffectfulQMLState Nothing
+
+-- | Define the effects for QML operations.
+data EffectfulQML :: Effect where
+  RunEngineLoop :: QML.EngineConfig -> QML.SignalKey (IO ()) -> EffectfulQML m ()
+  CreateSignalKey :: EffectfulQML m (QML.SignalKey (IO ()))
+  FireSignalWith :: QML.SignalKey (IO ()) -> QML.ObjRef () -> EffectfulQML m ()
+  FireSignal :: QML.ObjRef () -> EffectfulQML m ()
+
+
+type instance DispatchOf EffectfulQML = Dynamic
+
+makeEffect ''EffectfulQML
+
+-- | Handler for the QML effects.
+runEffectfulQML :: (IOE :> es) => Eff (EffectfulQML : State EffectfulQMLState : es) a -> Eff es a
+runEffectfulQML action = evalState initialState $ interpret handleEffectfulQML action
+  where
+    handleEffectfulQML
+      :: (IOE :> es)
+      => EffectHandler EffectfulQML (State EffectfulQMLState : es)
+    handleEffectfulQML _ = \case
+      RunEngineLoop config changeKey -> do
+        put $ EffectfulQMLState $ Just changeKey
+        liftIO $ QML.runEngineLoop config
+
+      CreateSignalKey -> liftIO $ QML.newSignalKey
+
+      FireSignalWith changeKey obj -> liftIO $ QML.fireSignal changeKey obj
+
+      FireSignal obj -> do
+        st <- get
+        case signalKey st of
+          Just s -> liftIO $ QML.fireSignal s obj
+          Nothing -> return()

src/Futr.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Futr where
+
+import Data.Map.Strict qualified as Map
+import Data.Text (pack, unpack)
+import Effectful
+import Effectful.Dispatch.Dynamic (EffectHandler, interpret)
+import Effectful.State.Static.Shared (State, get, modify)
+import Effectful.TH
+import EffectfulQML
+import Graphics.QML hiding (fireSignal, runEngineLoop)
+import Text.Read (readMaybe)
+
+import Nostr.Keys (KeyPair, secKeyToKeyPair)
+import Presentation.KeyMgmt qualified as PKeyMgmt
+
+data AppScreen
+    = KeyMgmt
+    | Relay
+    | Home
+    deriving (Eq, Read, Show)
+
+data Futr = Futr
+  { keyPair :: Maybe KeyPair
+  , currentScreen :: AppScreen
+  }
+
+initialState :: Futr
+initialState = Futr
+  { keyPair = Nothing
+  , currentScreen = KeyMgmt
+  }
+
+-- | Key Management Effect for creating QML context.
+data FutrContext :: Effect where
+  CreateCtx :: SignalKey (IO ()) -> FutrContext m (ObjRef ())
+
+type instance DispatchOf FutrContext = Dynamic
+
+makeEffect ''FutrContext
+
+type FutrEff es = (PKeyMgmt.KeyMgmtContext :> es, State Futr :> es, State PKeyMgmt.KeyMgmtState :> es, EffectfulQML :> es, IOE :> es)
+
+runFutrContext :: FutrEff es => Eff (FutrContext : es) a -> Eff es a
+runFutrContext action = interpret handleFutrContext action
+  where
+    handleFutrContext :: FutrEff es => EffectHandler FutrContext es
+    handleFutrContext _ = \case
+      CreateCtx changeKey' -> withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> do
+        keyMgmtObj <- runE $ PKeyMgmt.createCtx changeKey'
+
+        rootClass <- newClass [
+            defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj),
+
+            defPropertySigRW' "currentScreen" changeKey'
+                (\_ -> do
+                  st <- runE $ get :: IO Futr
+                  return $ pack $ show $ currentScreen st)
+                (\obj newScreen -> do
+                    case readMaybe (unpack newScreen) :: Maybe AppScreen of
+                        Just s -> do
+                            runE $ do
+                              modify $ \st -> st { currentScreen = s }
+                              fireSignal obj
+                        Nothing -> return ()),
+
+            defMethod' "login" $ \obj input -> do
+                st <- runE get :: IO PKeyMgmt.KeyMgmtState
+                case Map.lookup (PKeyMgmt.AccountId input) (PKeyMgmt.accountMap st) of
+                    Just a -> do
+                        runE $ do
+                          modify $ \st' -> st' { keyPair = Just $ secKeyToKeyPair $ PKeyMgmt.nsec a, currentScreen = Home }
+                          fireSignal obj
+                    Nothing ->
+                        return ()
+            ]
+
+        rootObj <- newObject rootClass ()
+        return rootObj

src/Main.hs

@@ -1,82 +1,17 @@
-{-# 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.FileSystem (runFileSystem)
+import Effectful.State.Static.Shared (evalState)
+import EffectfulQML
+import Graphics.QML qualified as QML
 import System.Environment (setEnv)
-import Text.Read (readMaybe)
-
-import Nostr.Keys (KeyPair, secKeyToKeyPair)
-import Presentation.KeyMgmt
-import Types
-
-data AppModel = AppModel
-    { keyPair :: Maybe KeyPair
-    , currentScreen :: AppScreen
-    , keyMgmtModel :: MVar KeyMgmtModel
-    } deriving (Typeable)
-
-createContext :: MVar AppModel -> SignalKey (IO ()) -> IO (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'
-
-    rootClass <- newClass [
-        defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj),
-
-        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
-                    Nothing -> return ()),
-
-        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
-                Nothing ->
-                    return ()
-        ]
-
-    rootObj <- newObject rootClass ()
-    return rootObj
 
+import Futr qualified as Futr
+import Presentation.KeyMgmt qualified as KeyMgmt
 
 main :: IO ()
 main = do
-    accounts <- listAccounts
-    keyMgmtM <- newMVar $ KeyMgmtModel accounts "" ""
-
-    let appModel = AppModel
-            { keyPair = Nothing
-            , currentScreen = Types.KeyMgmt
-            , keyMgmtModel = keyMgmtM
-            }
-
-    modelVar <- newMVar appModel
-    changeKey <- newSignalKey :: IO (SignalKey (IO ()))
-    ctx <- createContext modelVar changeKey
-
     let path = "qrc:/qml/main.qml"
     let importPath = "qrc:/qml"
     let importPath' = "qrc:/qml/content"
@@ -88,9 +23,25 @@ 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"
-        }
+    runEff
+        . runEffectfulQML
+        . runFileSystem
+        . evalState KeyMgmt.initialState
+        . KeyMgmt.runKeyMgmt
+        . KeyMgmt.runKeyMgmtContext
+        . evalState Futr.initialState
+        . Futr.runFutrContext
+
+        $ do
+            changeKey <- createSignalKey
+            ctx <- Futr.createCtx changeKey
+
+            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"
+                    }
+
+            KeyMgmt.loadAccounts
+            runEngineLoop config changeKey

src/Nostr/Effects/IDGen.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Nostr.Effects.IDGen where
+
+import Control.Monad (replicateM)
+import Data.ByteString qualified as BS
+import Data.ByteString.Base16 qualified as B16
+import Data.Text (Text)
+import Data.Text.Encoding qualified as TE
+import Effectful
+import Effectful.Dispatch.Dynamic (interpret)
+import Effectful.TH
+import System.Random (randomIO)
+
+-- | Effect for generating unique IDs.
+data IDGen :: Effect where
+  GenerateID :: Int -> IDGen m Text
+
+type instance DispatchOf IDGen = Dynamic
+
+makeEffect ''IDGen
+
+-- | Handler for the IDGen effect.
+runIDGenIO
+  :: IOE :> es
+  => Eff (IDGen : es) a
+  -> Eff es a
+runIDGenIO = interpret $ \_ -> \case
+  GenerateID n -> do
+    bytes <- liftIO $ replicateM n randomIO
+    let byteString = BS.pack bytes
+    return $ TE.decodeUtf8 $ B16.encode byteString