Rename Server -> Env; consolidate related modules

app/Main.hs

@@ -12,7 +12,7 @@ import Data.IORef
 import Data.Maybe
 import Ensemble.Config
 import Ensemble.Handler
-import Ensemble.Server
+import Ensemble.Env
 import Network.HTTP.Types (status400)
 import Network.Wai (responseLBS)
 import qualified Network.Wai.Handler.WebSockets as WaiWs
@@ -25,16 +25,16 @@ main :: IO ()
 main = do
     hSetBuffering stdout NoBuffering
     config <- getRecord "Ensemble Audio Engine"
-    server <- createServer config
-    runWebSocketInterface server (fromMaybe 3000 $ port config)
+    env <- createEnv config
+    runWebSocketInterface env (fromMaybe 3000 $ port config)
 
   where              
-    runWebSocketInterface server port' = do
+    runWebSocketInterface env port' = do
         let warpSettings = Warp.setPort port' Warp.defaultSettings
         let websocketApp pendingConnection = do
                 connection <- WS.acceptRequest pendingConnection
                 sendThread <- forkIO $ forever $ do
-                    outgoingMessage <- readChan $ server_messageChannel server
+                    outgoingMessage <- readChan $ env_messageChannel env
                     WS.sendTextData connection (A.encode outgoingMessage)
                 isOpen <- newIORef True 
                 whileM $ do
@@ -53,20 +53,20 @@ main = do
                         WS.UnicodeException message -> do
                             putStrLn $ "UNICODE EXCEPTION: " <> message
                             pure Nothing
-                    whenJust incomingMessage $ handleIncomingMessage server
+                    whenJust incomingMessage $ handleIncomingMessage env
                     readIORef isOpen
         let backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
         Warp.runSettings warpSettings $ WaiWs.websocketsOr WS.defaultConnectionOptions websocketApp backupApp
 
-    handleIncomingMessage server message = 
+    handleIncomingMessage env message = 
         case A.eitherDecodeStrict message of
             Right incomingMessage -> do
-                outgoingMessage <- receiveMessage server incomingMessage
-                writeChan (server_messageChannel server) outgoingMessage
+                outgoingMessage <- receiveMessage env incomingMessage
+                writeChan (env_messageChannel env) outgoingMessage
             Left parseError -> 
                 hPutStrLn stderr $ "Parse error: " <> parseError
 
-    handleOutgoingMessages server = 
+    handleOutgoingMessages env = 
         void $ forkIO $ forever $ do
-            outgoingMessage <- readChan $ server_messageChannel server
+            outgoingMessage <- readChan $ env_messageChannel env
             putStrLn $ LC8.unpack (A.encode outgoingMessage)

ensemble.cabal

@@ -46,8 +46,8 @@ library
     exposed-modules:  Ensemble,
                       Ensemble.API,
                       Ensemble.Config,
-                      Ensemble.Effects,
                       Ensemble.Engine,
+                      Ensemble.Env,
                       Ensemble.Error,
                       Ensemble.Event,
                       Ensemble.Handler,
@@ -56,9 +56,7 @@ library
                       Ensemble.Schema.TaggedJSON,
                       Ensemble.Schema.TH,
                       Ensemble.Sequencer,
-                      Ensemble.Server,
                       Ensemble.Tick,
-                      Ensemble.Type,
                       Ensemble.Util,
                       Ensemble.Window
     if os(windows)

src/Ensemble.hs

@@ -1,7 +1,7 @@
 module Ensemble 
   ( module Ensemble.API
-  , module Ensemble.Server
+  , module Ensemble.Env
   ) where
 
 import Ensemble.API
-import Ensemble.Server
+import Ensemble.Env

src/Ensemble/API.hs

@@ -22,9 +22,8 @@ import Ensemble.Node
 import Ensemble.Event (SequencerEvent(..))
 import Ensemble.Schema.TH
 import qualified Ensemble.Sequencer as Sequencer
-import Ensemble.Server
+import Ensemble.Env
 import Ensemble.Tick
-import Ensemble.Type
 import Ensemble.Window
 import Foreign.Ptr
 
@@ -39,24 +38,24 @@ getMidiDevices = liftIO Engine.getMidiDevices
 
 startEngine :: Ensemble Ok
 startEngine = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.start engine
     pure Ok
 
 stopEngine :: Ensemble Ok
 stopEngine = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.stop engine
     pure Ok
 
 createMidiDeviceNode :: Argument "deviceId" Int -> Ensemble NodeId
 createMidiDeviceNode (Argument deviceId) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.createMidiDeviceNode engine deviceId
 
 deleteNode :: Argument "nodeId" NodeId -> Ensemble Ok
 deleteNode (Argument nodeId) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.deleteNode engine nodeId
     pure Ok 
 
@@ -71,7 +70,7 @@ scanForPlugins (Argument filePaths) =
 
 createPluginNode :: Argument "filePath" Text -> Argument "pluginIndex" Int -> Ensemble NodeId
 createPluginNode (Argument filePath) (Argument pluginIndex) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.createPluginNode engine $ Clap.PluginLocation (unpack filePath) pluginIndex
 
 data Size = Size
@@ -88,7 +87,7 @@ data WindowInfo = WindowInfo
 
 openPluginGUI :: Argument "nodeId" NodeId -> Argument "name" Text -> Argument "parentWindow" (Maybe Int) -> Argument "scale" Double -> Argument "preferredSize" (Maybe Size) -> Ensemble Size
 openPluginGUI (Argument nodeId) (Argument name) (Argument maybeParentWindow) (Argument scale) (Argument maybePreferredSize) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     maybeNode <- liftIO $ Engine.lookupNode engine nodeId
     case maybeNode of
         Just (Node_Plugin pluginNode) -> do
@@ -120,7 +119,7 @@ openPluginGUI (Argument nodeId) (Argument name) (Argument maybeParentWindow) (Ar
                     unless setParentResult $ Engine.throwApiError "Error setting parent window of plugin GUI"
                     showResult <- liftIO $ Gui.show pluginGuiHandle pluginHandle
                     unless showResult $ Engine.throwApiError "Error showing plugin GUI"
-                    pluginGuiThreadIdIORef <- asks server_pluginGuiThreadId
+                    pluginGuiThreadIdIORef <- asks env_pluginGuiThreadId
                     pluginGuiThreadId <- liftIO $ readIORef pluginGuiThreadIdIORef
                     unless (isJust pluginGuiThreadId) $ do
                         newPluginGuiThreadId <- liftIO $ forkIO messagePump
@@ -132,7 +131,7 @@ openPluginGUI (Argument nodeId) (Argument name) (Argument maybeParentWindow) (Ar
 
 getPluginParameters :: Argument "nodeId" NodeId -> Ensemble [ParameterInfo]
 getPluginParameters  (Argument nodeId) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     maybeNode <- liftIO $ Engine.lookupNode engine nodeId
     case maybeNode of
         Just (Node_Plugin pluginNode) -> do 
@@ -149,7 +148,7 @@ getPluginParameters  (Argument nodeId) = do
 
 getPluginParameterValue :: Argument "nodeId" NodeId -> Argument "parameterId" Int -> Ensemble (Maybe Double)
 getPluginParameterValue  (Argument nodeId) (Argument parameterId) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     maybeNode <- liftIO $ Engine.lookupNode engine nodeId
     case maybeNode of
         Just (Node_Plugin pluginNode) -> do 
@@ -164,20 +163,20 @@ getPluginParameterValue  (Argument nodeId) (Argument parameterId) = do
 -- Sequencer
 sendEvent :: Argument "sequencerEvent" SequencerEvent -> Ensemble Ok
 sendEvent (Argument event) = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.sendEventNow engine event
     pure Ok
 
 scheduleEvent :: Argument "tick" Tick -> Argument "sequencerEvent" SequencerEvent -> Ensemble Ok
 scheduleEvent (Argument tick) (Argument event) = do
-    sequencer <- asks server_sequencer
+    sequencer <- asks env_sequencer
     liftIO $ Sequencer.sendAt sequencer tick event
     pure Ok
 
 playSequence :: Argument "startTick" Tick -> Argument "endTick" (Maybe Tick) -> Argument "loop" Bool -> Ensemble Ok
 playSequence (Argument startTick) (Argument maybeEndTick) (Argument loop) = do
-    sequencer <- asks server_sequencer
-    engine <- asks server_engine
+    sequencer <- asks env_sequencer
+    engine <- asks env_engine
     void $ liftIO $ do
         maybeThreadId <- readIORef (Engine.engine_playbackThread engine)
         unless (isJust maybeThreadId) $ do
@@ -189,22 +188,22 @@ playSequence (Argument startTick) (Argument maybeEndTick) (Argument loop) = do
 
 renderSequence :: Argument "startTick" Tick -> Argument "endTick" (Maybe Tick) -> Ensemble AudioOutput
 renderSequence (Argument startTick) (Argument maybeEndTick) = do
-    sequencer <- asks server_sequencer
-    engine <- asks server_engine
+    sequencer <- asks env_sequencer
+    engine <- asks env_engine
     endTick <- case maybeEndTick of
         Just endTick -> pure endTick
         Nothing -> liftIO $ Sequencer.getEndTick sequencer
     liftIO $ Sequencer.renderSequence sequencer engine startTick endTick
 
 clearSequence :: Ensemble Ok
 clearSequence = do
-    eventQueue <- asks (Sequencer.sequencer_eventQueue . server_sequencer)
+    eventQueue <- asks (Sequencer.sequencer_eventQueue . env_sequencer)
     liftIO $ writeIORef eventQueue []
     pure Ok
 
 stopPlayback :: Ensemble Ok
 stopPlayback = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ do
         maybePlaybackThreadId <- readIORef (Engine.engine_playbackThread engine)
         whenJust maybePlaybackThreadId killThread
@@ -213,7 +212,7 @@ stopPlayback = do
 
 getCurrentTick :: Ensemble Tick
 getCurrentTick = do
-    engine <- asks server_engine
+    engine <- asks env_engine
     liftIO $ Engine.getCurrentTick engine
 
 ping :: Ensemble Ok

src/Ensemble/Engine.hs

@@ -226,7 +226,7 @@ sendEvents engine events = do
                 Just startTime -> pure startTime
                 Nothing -> do
                     let (PaTime currentTime) = PortAudio.currentTime undefined
-                    let startTime = round $ currentTime * 1000 - (fromIntegral $ midiDeviceNode_latency midiDeviceNode) 
+                    let startTime = round $ currentTime * 1000 - fromIntegral (midiDeviceNode_latency midiDeviceNode) 
                     writeIORef (midiDeviceNode_startTime midiDeviceNode) (Just startTime)
                     pure startTime 
             steadyTime <- readIORef (engine_steadyTime engine)
@@ -406,7 +406,7 @@ getAudioStream engine = do
     maybeAudioStream <- liftIO $ readIORef (engine_audioStream engine)
     case maybeAudioStream of
         Just audioStream -> pure audioStream
-        Nothing -> throwApiError $ "Audio Stream not available"
+        Nothing -> throwApiError "Audio Stream not available"
 
 getAudioStreamInfo :: Engine -> IO PaStreamInfo
 getAudioStreamInfo engine = do

src/Ensemble/Env.hs

@@ -0,0 +1,42 @@
+
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Ensemble.Env where
+
+import Clap.Interface.Host
+import Control.Concurrent
+import Control.Monad.Reader
+import Data.Aeson (Value)
+import Data.IORef
+import Ensemble.Config
+import Ensemble.Engine
+import Ensemble.Sequencer
+
+newtype Ensemble a = Ensemble { unEnsemble :: ReaderT Env IO a }
+    deriving newtype (Monad, Applicative, Functor, MonadReader Env, MonadIO)
+
+data Env = Env 
+  { env_config :: Config
+  , env_sequencer :: Sequencer
+  , env_engine :: Engine
+  , env_messageChannel :: Chan Value
+  , env_pluginGuiThreadId :: IORef (Maybe ThreadId)
+  }
+
+createEnv :: Config -> IO Env
+createEnv config = do
+  sequencer <- createSequencer
+  engine <- createEngine defaultHostConfig
+  messageChannel <- newChan
+  pluginGuiThreadId <- newIORef Nothing
+  pure $ Env
+    { env_config = config
+    , env_sequencer = sequencer
+    , env_engine = engine
+    , env_messageChannel = messageChannel
+    , env_pluginGuiThreadId = pluginGuiThreadId
+    }
+
+runEnsemble :: Env -> Ensemble a -> IO a
+runEnsemble env action = runReaderT (unEnsemble action) env

src/Ensemble/Handler.hs

@@ -9,18 +9,17 @@ import qualified Data.Aeson as A
 import Data.Aeson.KeyMap (KeyMap)
 import qualified Data.Aeson.KeyMap as KeyMap
 import Data.Maybe
-import Ensemble.Effects
 import Ensemble.Error
 import Ensemble.Schema (handleMessage)
 import Ensemble.Schema.TH
 import Ensemble.Schema.TaggedJSON (toTaggedJSON)
-import Ensemble.Server
+import Ensemble.Env
 import GHC.Stack
 
 deriveJSON ''ApiError
 
-handler :: HasCallStack => Server -> KeyMap A.Value -> IO (KeyMap A.Value)
-handler server object = runEnsemble server $
+handler :: HasCallStack => Env -> KeyMap A.Value -> IO (KeyMap A.Value)
+handler env object = runEnsemble env $
     case KeyMap.lookup "@type" object of
         Just (A.String messageType) -> 
             handleMessage messageType object
@@ -29,11 +28,11 @@ handler server object = runEnsemble server $
         Nothing -> 
             throw $ ApiError "Message is missing '@type' field"
 
-receiveMessage :: HasCallStack => Server -> A.Value -> IO A.Value
-receiveMessage server = \case
+receiveMessage :: HasCallStack => Env -> A.Value -> IO A.Value
+receiveMessage env = \case
     A.Object object -> do
         let extraValue = KeyMap.lookup "@extra" object
-        outMessage <- handler server object
+        outMessage <- handler env object
         pure $ A.Object $ KeyMap.insert "@extra" (fromMaybe A.Null extraValue) outMessage
     _ -> pure $ makeError Nothing $ ApiError "Invalid JSON input, needs to be object"
     where

src/Ensemble/Schema.hs

@@ -16,7 +16,7 @@ import Ensemble.Engine (AudioDevice(..), AudioOutput(..), MidiDevice(..))
 import Ensemble.Error
 import Ensemble.Event
 import Ensemble.Schema.TH
-import Ensemble.Type
+import Ensemble.Env
 
 makeAPI
     -- types