diff --git a/minipat-dirt/minipat-dirt.cabal b/minipat-dirt/minipat-dirt.cabal
index 80b2adc..14b3246 100644
--- a/minipat-dirt/minipat-dirt.cabal
+++ b/minipat-dirt/minipat-dirt.cabal
@@ -28,6 +28,7 @@ library
       Minipat.Dirt.Boot
       Minipat.Dirt.Combinators
       Minipat.Dirt.Core
+      Minipat.Dirt.DirtCore
       Minipat.Dirt.Logger
       Minipat.Dirt.Notes
       Minipat.Dirt.Osc
diff --git a/minipat-dirt/src/Minipat/Dirt/Attrs.hs b/minipat-dirt/src/Minipat/Dirt/Attrs.hs
index cb76029..7a9ac2d 100644
--- a/minipat-dirt/src/Minipat/Dirt/Attrs.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Attrs.hs
@@ -9,6 +9,7 @@ module Minipat.Dirt.Attrs
   , attrsFromList
   , attrsLookup
   , attrsInsert
+  , attrsDefault
   , attrsDelete
   , attrsToList
   , IsAttrs (..)
@@ -90,6 +91,11 @@ attrsLookup k (Attrs m) = Map.lookup k m
 attrsInsert :: Text -> Datum -> Attrs -> Attrs
 attrsInsert k v (Attrs m) = Attrs (Map.insert k v m)
 
+attrsDefault :: Text -> Datum -> Attrs -> Attrs
+attrsDefault k v a@(Attrs m) = case Map.lookup k m of
+  Nothing -> Attrs (Map.insert k v m)
+  Just _ -> a
+
 attrsDelete :: Text -> Attrs -> Attrs
 attrsDelete k (Attrs m) = Attrs (Map.delete k m)
 
diff --git a/minipat-dirt/src/Minipat/Dirt/Boot.hs b/minipat-dirt/src/Minipat/Dirt/Boot.hs
index 740a4c6..9a09582 100644
--- a/minipat-dirt/src/Minipat/Dirt/Boot.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Boot.hs
@@ -5,6 +5,7 @@ module Minipat.Dirt.Boot where
 
 import Minipat.Dirt.Attrs (Attrs, IsAttrs (..))
 import Minipat.Dirt.Core qualified as C
+import Minipat.Dirt.DirtCore qualified as D
 import Minipat.Dirt.Logger qualified as L
 import Minipat.EStream (EStream)
 import Minipat.Stream (Stream)
@@ -12,13 +13,13 @@ import Nanotime (TimeDelta)
 import Prettyprinter (Pretty)
 
 class Minipat where
-  minipat :: C.St
+  minipat :: D.DirtSt
 
-initialize :: IO C.St
+initialize :: IO D.DirtSt
 initialize = do
   logger <- L.newLogger
   L.logInfo logger "Initializing"
-  C.initSt logger C.defaultEnv
+  C.initSt logger D.dirtImpl (C.defaultEnv D.defaultDirtEnv)
 
 dispose :: (Minipat) => IO ()
 dispose = C.disposeSt minipat
@@ -81,7 +82,7 @@ stop :: (Minipat) => IO ()
 stop = setPlaying False
 
 handshake :: (Minipat) => IO ()
-handshake = C.handshake minipat
+handshake = D.handshake minipat
 
 checkTasks :: (Minipat) => IO ()
 checkTasks = C.checkTasks minipat
diff --git a/minipat-dirt/src/Minipat/Dirt/Core.hs b/minipat-dirt/src/Minipat/Dirt/Core.hs
index 03eca30..7a19b66 100644
--- a/minipat-dirt/src/Minipat/Dirt/Core.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Core.hs
@@ -2,19 +2,13 @@
 
 module Minipat.Dirt.Core where
 
-import Control.Concurrent (forkFinally)
-import Control.Concurrent.Async (Async, async, cancel, poll, waitCatch)
+import Control.Concurrent.Async (Async, poll)
 import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryTakeMVar, withMVar)
 import Control.Concurrent.STM (STM, atomically)
-import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, newTQueueIO, writeTQueue)
+import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, newTQueueIO)
 import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar, readTVarIO, stateTVar, writeTVar)
-import Control.Exception (Exception (..), SomeException, bracket, mask_, onException, throwIO)
-import Control.Monad (unless, void, when)
-import Control.Monad.IO.Class (liftIO)
-import Dahdit.Midi.Osc (Datum (..), Packet)
-import Dahdit.Network (Conn (..), HostPort (..), resolveAddr, runDecoder, runEncoder, udpServerConn)
-import Data.Acquire (Acquire)
-import Data.Either (isRight)
+import Control.Exception (Exception (..), mask_)
+import Control.Monad (unless, void)
 import Data.Foldable (foldl', for_)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -23,46 +17,43 @@ import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
 import Data.Text (Text)
 import Data.Text qualified as T
-import Minipat.Dirt.Attrs (Attrs, attrsInsert)
-import Minipat.Dirt.Logger (LogAction, logDebug, logError, logInfo, logWarn, newLogger)
-import Minipat.Dirt.Osc (PlayEnv (..), PlayErr, convertTape, handshakePacket, playPacket)
-import Minipat.Dirt.Resources (RelVar, Timed (..), acquireAwait, acquireLoop, relVarAcquire, relVarDispose, relVarInit)
+import Minipat.Dirt.Logger (LogAction, logDebug, logError, logInfo, logWarn)
+import Minipat.Dirt.Resources (RelVar, Timed (..), relVarDispose, relVarUse)
 import Minipat.EStream (EStream (..))
 import Minipat.Print (prettyPrint, prettyPrintAll, prettyShow, prettyShowAll)
 import Minipat.Stream (Stream, streamRun, tapeToList)
 import Minipat.Time (Arc (..), CycleTime (..), bpmToCps, cpsToBpm)
 import Nanotime
-  ( PosixTime (..)
-  , TimeDelta
-  , TimeLike (..)
-  , threadDelayDelta
+  ( TimeDelta
   , timeDeltaFromFracSecs
   )
-import Network.Socket qualified as NS
 import Prettyprinter (Pretty)
 
-data Env = Env
-  { envTargetHp :: !HostPort
-  , envListenHp :: !HostPort
-  , envDebug :: !Bool
-  , envCps :: !Rational
-  , envGpc :: !Integer
-  , envOscTimeout :: !TimeDelta
+data CommonEnv = CommonEnv
+  { ceDebug :: !Bool
+  , ceCps :: !Rational
+  , ceGpc :: !Integer
   }
   deriving stock (Eq, Ord, Show)
 
-defaultEnv :: Env
-defaultEnv =
-  Env
-    { envTargetHp = HostPort (Just "127.0.0.1") 57120
-    , envListenHp = HostPort (Just "127.0.0.1") 57129
-    , envDebug = False
-    , envCps = 1 % 2 -- 120 bpm, 4 bpc
-    , envGpc = 8 -- Number of gens per cycle
-    , envOscTimeout = timeDeltaFromFracSecs @Double 0.1
+defaultCommonEnv :: CommonEnv
+defaultCommonEnv =
+  CommonEnv
+    { ceDebug = False
+    , ceCps = 1 % 2 -- 120 bpm, 4 bpc
+    , ceGpc = 8 -- Number of gens per cycle
     }
 
-data Domain = Domain
+data Env i = Env
+  { envCommon :: !CommonEnv
+  , envImpl :: !i
+  }
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+defaultEnv :: i -> Env i
+defaultEnv = Env defaultCommonEnv
+
+data Domain x y = Domain
   { domDebug :: !(TVar Bool)
   , domCps :: !(TVar Rational)
   , domGpc :: !(TVar Integer)
@@ -70,13 +61,13 @@ data Domain = Domain
   , domPlaying :: !(TVar Bool)
   , domGenCycle :: !(TVar Integer)
   , domAbsGenCycle :: !(TVar Integer)
-  , domOrbits :: !(TVar (Map Integer (Stream Attrs)))
-  , domStream :: !(TVar (Stream Attrs))
-  , domQueue :: !(TQueue (Timed Packet))
+  , domOrbits :: !(TVar (Map Integer (Stream x)))
+  , domStream :: !(TVar (Stream x))
+  , domQueue :: !(TQueue (Timed y))
   -- TODO bound the queue
   }
 
-newDomain :: IO Domain
+newDomain :: IO (Domain x y)
 newDomain =
   Domain
     <$> newTVarIO False
@@ -90,15 +81,15 @@ newDomain =
     <*> newTVarIO mempty
     <*> newTQueueIO
 
-initDomain :: Env -> IO Domain
-initDomain env = newDomain >>= \d -> d <$ reinitDomain env d
+initDomain :: CommonEnv -> IO (Domain x y)
+initDomain ce = newDomain >>= \d -> d <$ reinitDomain ce d
 
-reinitDomain :: Env -> Domain -> IO ()
-reinitDomain env dom = atomically $ do
-  let cps = envCps env
-      gpc = envGpc env
+reinitDomain :: CommonEnv -> Domain x y -> IO ()
+reinitDomain ce dom = atomically $ do
+  let cps = ceCps ce
+      gpc = ceGpc ce
       ahead = timeDeltaFromFracSecs (1 / (cps * fromInteger gpc))
-  writeTVar (domDebug dom) (envDebug env)
+  writeTVar (domDebug dom) (ceDebug ce)
   writeTVar (domCps dom) cps
   writeTVar (domGpc dom) gpc
   writeTVar (domAhead dom) ahead
@@ -109,47 +100,84 @@ reinitDomain env dom = atomically $ do
   writeTVar (domStream dom) mempty
   void (flushTQueue (domQueue dom))
 
-getDebug :: St -> IO Bool
+type Spawner i d x y = LogAction -> Domain x y -> RelVar -> i -> IO (Map Text (Async ()), d)
+
+data Impl i d x y = Impl
+  { implSpawn :: !(Spawner i d x y)
+  , implAddOrbit :: !(Integer -> x -> x)
+  }
+
+data Resources d = Resources
+  { resRel :: !RelVar
+  , resTasks :: !(Map Text (Async ()))
+  , resData :: !d
+  }
+
+data St i d x y = St
+  { stLogger :: !LogAction
+  , stImpl :: !(Impl i d x y)
+  , stEnv :: !(Env i)
+  , stDom :: !(Domain x y)
+  , stRes :: !(MVar (Resources d))
+  }
+
+newSt :: LogAction -> Impl i d x y -> Env i -> IO (St i d x y)
+newSt logger impl env = St logger impl env <$> initDomain (envCommon env) <*> newEmptyMVar
+
+initRes :: St i d x y -> IO ()
+initRes st = do
+  disposeSt st
+  relVarUse $ \rv -> do
+    (tasks, dat) <- implSpawn (stImpl st) (stLogger st) (stDom st) rv (envImpl (stEnv st))
+    putMVar (stRes st) (Resources rv tasks dat)
+
+initSt :: LogAction -> Impl i d x y -> Env i -> IO (St i d x y)
+initSt logger impl env = newSt logger impl env >>= \st -> st <$ initRes st
+
+disposeSt :: St i d x y -> IO ()
+disposeSt st = mask_ (tryTakeMVar (stRes st) >>= maybe (pure ()) (relVarDispose . resRel))
+
+getDebug :: St i d x y -> IO Bool
 getDebug = readTVarIO . domDebug . stDom
 
-getCps :: St -> IO Rational
+getCps :: St i d x y -> IO Rational
 getCps = readTVarIO . domCps . stDom
 
-getGpc :: St -> IO Integer
+getGpc :: St i d x y -> IO Integer
 getGpc = readTVarIO . domGpc . stDom
 
-getAhead :: St -> IO TimeDelta
+getAhead :: St i d x y -> IO TimeDelta
 getAhead = readTVarIO . domAhead . stDom
 
-getPlaying :: St -> IO Bool
+getPlaying :: St i d x y -> IO Bool
 getPlaying = readTVarIO . domPlaying . stDom
 
-getStream :: St -> IO (Stream Attrs)
+getStream :: St i d x y -> IO (Stream x)
 getStream = readTVarIO . domStream . stDom
 
-getGenCycle :: St -> IO Integer
+getGenCycle :: St i d x y -> IO Integer
 getGenCycle = readTVarIO . domGenCycle . stDom
 
-getAbsGenCycle :: St -> IO Integer
+getAbsGenCycle :: St i d x y -> IO Integer
 getAbsGenCycle = readTVarIO . domAbsGenCycle . stDom
 
-getCycle :: St -> IO Integer
+getCycle :: St i d x y -> IO Integer
 getCycle st = atomically $ do
   let dom = stDom st
   gpc <- readTVar (domGpc dom)
   gcyc <- readTVar (domGenCycle dom)
   pure (div gcyc gpc)
 
-getTempo :: St -> IO Rational
+getTempo :: St i d x y -> IO Rational
 getTempo = fmap (cpsToBpm 4) . getCps
 
-setDebug :: St -> Bool -> IO ()
+setDebug :: St i d x y -> Bool -> IO ()
 setDebug st = atomically . writeTVar (domDebug (stDom st))
 
-setTempo :: St -> Rational -> IO ()
+setTempo :: St i d x y -> Rational -> IO ()
 setTempo st = setCps st . bpmToCps 4
 
-setCps :: St -> Rational -> IO ()
+setCps :: St i d x y -> Rational -> IO ()
 setCps st cps' = atomically $ do
   let dom = stDom st
   gpc <- readTVar (domGpc dom)
@@ -157,10 +185,10 @@ setCps st cps' = atomically $ do
   writeTVar (domCps dom) cps'
   writeTVar (domAhead dom) ahead'
 
-setPlaying :: St -> Bool -> IO ()
+setPlaying :: St i d x y -> Bool -> IO ()
 setPlaying st x = atomically (writeTVar (domPlaying (stDom st)) x)
 
-setCycle :: St -> Integer -> IO ()
+setCycle :: St i d x y -> Integer -> IO ()
 setCycle st x = atomically $ do
   let dom = stDom st
   gpc <- readTVar (domGpc dom)
@@ -168,57 +196,40 @@ setCycle st x = atomically $ do
   let y = x * gpc + mod gcyc gpc
   writeTVar (domGenCycle (stDom st)) y
 
--- TODO only set orbit if not present
-updateOrbits :: St -> (Map Integer (Stream Attrs) -> Map Integer (Stream Attrs)) -> IO ()
+updateOrbits :: St i d x y -> (Map Integer (Stream x) -> Map Integer (Stream x)) -> IO ()
 updateOrbits st f = atomically $ do
   let dom = stDom st
+      addOrbit = implAddOrbit (stImpl st)
   m' <- stateTVar (domOrbits dom) (\m -> let m' = f m in (m', m'))
-  let z = foldl' (\x (o, y) -> x <> fmap (attrsInsert "orbit" (DatumInt32 (fromIntegral o))) y) mempty (Map.toList m')
+  let z = foldl' (\x (o, y) -> x <> fmap (addOrbit o) y) mempty (Map.toList m')
   writeTVar (domStream dom) z
 
-setOrbit :: St -> Integer -> EStream Attrs -> IO ()
+setOrbit :: St i d x y -> Integer -> EStream x -> IO ()
 setOrbit st o es =
   case unEStream es of
     Left e -> putStrLn (displayException e)
     Right s -> updateOrbits st (Map.insert o s)
 
-clearOrbit :: St -> Integer -> IO ()
+clearOrbit :: St i d x y -> Integer -> IO ()
 clearOrbit st o = updateOrbits st (Map.delete o)
 
-clearAllOrbits :: St -> IO ()
+clearAllOrbits :: St i d x y -> IO ()
 clearAllOrbits st = atomically (clearAllOrbitsSTM (stDom st))
 
-hush :: St -> IO ()
+hush :: St i d x y -> IO ()
 hush st = atomically $ do
   let dom = stDom st
   clearAllOrbitsSTM dom
   flushQueueSTM dom
 
-panic :: St -> IO ()
+panic :: St i d x y -> IO ()
 panic st = atomically $ do
   let dom = stDom st
   clearAllOrbitsSTM dom
   flushQueueSTM dom
   writeTVar (domPlaying dom) False
 
--- | Handshake with SuperDirt
--- On success set playing true; on error false
-handshake :: St -> IO ()
-handshake st = bracket acq rel (const (pure ()))
- where
-  logger = stLogger st
-  acq = do
-    logInfo logger "Handshaking ..."
-    withMVar (stRes st) (flip sendPacket handshakePacket . resConn)
-    recvPacket st
-  rel resp = do
-    let ok = isRight resp
-    if ok
-      then logInfo logger "... handshake succeeded"
-      else logError logger "... handshake FAILED"
-    setPlaying st ok
-
-peek :: (Pretty a) => St -> EStream a -> IO ()
+peek :: (Pretty a) => St i d x y -> EStream a -> IO ()
 peek st es =
   case unEStream es of
     Left e -> putStrLn (displayException e)
@@ -229,69 +240,19 @@ peek st es =
       prettyPrint arc
       prettyPrintAll "\n" evs
 
-clearAllOrbitsSTM :: Domain -> STM ()
+clearAllOrbitsSTM :: Domain x y -> STM ()
 clearAllOrbitsSTM dom = do
   writeTVar (domOrbits dom) mempty
   writeTVar (domStream dom) mempty
 
-flushQueueSTM :: Domain -> STM ()
+flushQueueSTM :: Domain x y -> STM ()
 flushQueueSTM dom = void (flushTQueue (domQueue dom))
 
-genEventsSTM :: Domain -> PosixTime -> STM (PlayEnv, Either PlayErr (Seq (Timed Attrs)))
-genEventsSTM dom now = do
-  ahead <- readTVar (domAhead dom)
-  cps <- readTVar (domCps dom)
-  gpc <- readTVar (domGpc dom)
-  gcyc <- readTVar (domGenCycle dom)
-  let start = CycleTime (gcyc % gpc)
-      end = CycleTime ((gcyc + 1) % gpc)
-      arc = Arc start end
-  stream <- readTVar (domStream dom)
-  let tape = streamRun stream arc
-      origin = addTime now ahead
-      penv = PlayEnv origin start cps
-      mpevs = convertTape penv tape
-  pure (penv, mpevs)
-
-advanceCycleSTM :: Domain -> STM ()
+advanceCycleSTM :: Domain x y -> STM ()
 advanceCycleSTM dom = do
   modifyTVar' (domGenCycle dom) (+ 1)
   modifyTVar' (domAbsGenCycle dom) (+ 1)
 
-data OscConn = OscConn
-  { ocTargetAddr :: !NS.SockAddr
-  , ocListenConn :: !(Conn NS.SockAddr)
-  }
-
-data Resources = Resources
-  { resRel :: !RelVar
-  , resConn :: !OscConn
-  , resGenTask :: !(Async ())
-  , resSendTask :: !(Async ())
-  }
-
-data St = St
-  { stLogger :: !LogAction
-  , stEnv :: !Env
-  , stDom :: !Domain
-  , stRes :: !(MVar Resources)
-  }
-
-acqConn :: Env -> Acquire OscConn
-acqConn (Env targetHp listenHp _ _ _ _) = do
-  targetAddr <- liftIO (resolveAddr targetHp)
-  conn <- udpServerConn Nothing listenHp
-  pure (OscConn targetAddr conn)
-
-acqGenTask :: LogAction -> Domain -> Acquire (Async ())
-acqGenTask logger dom = acquireLoop (domAhead dom) (doGen logger dom)
-
-acqSendTask :: OscConn -> Domain -> Acquire (Async ())
-acqSendTask conn dom = acquireAwait (domPlaying dom) (domQueue dom) (doSend conn)
-
-newSt :: LogAction -> Env -> IO St
-newSt logger env = St logger env <$> initDomain env <*> newEmptyMVar
-
 logAsyncState :: LogAction -> Text -> Async () -> IO ()
 logAsyncState logger name task = do
   mea <- poll task
@@ -302,35 +263,12 @@ logAsyncState logger name task = do
         Left e -> logError logger ("Task " <> name <> " failed:\n" <> T.pack (displayException e))
         Right _ -> logWarn logger ("Task " <> name <> " not running")
 
-checkTasks :: St -> IO ()
-checkTasks st = do
-  let logger = stLogger st
-  withMVar (stRes st) $ \res -> do
-    logAsyncState logger "gen" (resGenTask res)
-    logAsyncState logger "send" (resSendTask res)
-
-initRes :: St -> IO ()
-initRes st = do
-  disposeSt st
-  rv <- relVarInit
-  flip onException (relVarDispose rv) $ do
-    conn <- relVarAcquire rv (acqConn (stEnv st))
-    genTask <- relVarAcquire rv (acqGenTask (stLogger st) (stDom st))
-    sendTask <- relVarAcquire rv (acqSendTask conn (stDom st))
-    putMVar (stRes st) (Resources rv conn genTask sendTask)
-
-initSt :: LogAction -> Env -> IO St
-initSt logger env = newSt logger env >>= \st -> st <$ initRes st
-
-disposeSt :: St -> IO ()
-disposeSt st = mask_ (tryTakeMVar (stRes st) >>= maybe (pure ()) (relVarDispose . resRel))
-
-withSt :: (St -> IO a) -> IO a
-withSt f = do
-  logger <- newLogger
-  bracket (initSt logger defaultEnv) disposeSt f
+checkTasks :: St i d x y -> IO ()
+checkTasks st =
+  withMVar (stRes st) $ \res ->
+    for_ (Map.toList (resTasks res)) (uncurry (logAsyncState (stLogger st)))
 
-logEvents :: LogAction -> Domain -> Seq (Timed Attrs) -> IO ()
+logEvents :: (Pretty a) => LogAction -> Domain x y -> Seq (Timed a) -> IO ()
 logEvents logger dom pevs =
   unless (Seq.null pevs) $ do
     gpc <- readTVarIO (domGpc dom)
@@ -340,39 +278,5 @@ logEvents logger dom pevs =
         arc = Arc start end
     logDebug logger ("Generated @ " <> prettyShow arc <> "\n" <> prettyShowAll "\n" pevs)
 
-doGen :: LogAction -> Domain -> PosixTime -> IO ()
-doGen logger dom now = do
-  mr <- atomically $ do
-    playing <- readTVar (domPlaying dom)
-    if playing
-      then fmap Just (genEventsSTM dom now)
-      else pure Nothing
-  case mr of
-    Nothing -> pure ()
-    Just (_, mpevs) ->
-      case mpevs of
-        Left err -> logError logger (T.pack ("Gen failed: " ++ show err))
-        Right pevs -> do
-          debug <- readTVarIO (domDebug dom)
-          when debug (logEvents logger dom pevs)
-          atomically $ do
-            advanceCycleSTM dom
-            for_ pevs (writeTQueue (domQueue dom) . fmap playPacket)
-
-doSend :: OscConn -> Timed Packet -> IO ()
-doSend conn (Timed _ val) = do sendPacket conn val
-
-sendPacket :: OscConn -> Packet -> IO ()
-sendPacket (OscConn targetAddr (Conn _ enc)) = runEncoder enc targetAddr
-
-withTimeout :: TimeDelta -> IO a -> IO (Either SomeException a)
-withTimeout td act = do
-  thread <- async act
-  _ <- forkFinally (threadDelayDelta td) (const (cancel thread))
-  waitCatch thread
-
-recvPacket :: St -> IO (Either SomeException Packet)
-recvPacket st = withMVar (stRes st) $ \res -> do
-  let OscConn _ (Conn dec _) = resConn res
-  withTimeout (envOscTimeout (stEnv st)) $
-    runDecoder dec >>= either throwIO pure . snd
+withData :: St i d x y -> (d -> IO a) -> IO a
+withData st f = withMVar (stRes st) (f . resData)
diff --git a/minipat-dirt/src/Minipat/Dirt/DirtCore.hs b/minipat-dirt/src/Minipat/Dirt/DirtCore.hs
new file mode 100644
index 0000000..3164e63
--- /dev/null
+++ b/minipat-dirt/src/Minipat/Dirt/DirtCore.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Minipat.Dirt.DirtCore
+  ( DirtEnv (..)
+  , defaultDirtEnv
+  , DirtSt
+  , dirtImpl
+  , handshake
+  )
+where
+
+import Control.Concurrent (forkFinally)
+import Control.Concurrent.Async (Async, async, cancel, waitCatch)
+import Control.Concurrent.STM (STM, atomically)
+import Control.Concurrent.STM.TQueue (writeTQueue)
+import Control.Concurrent.STM.TVar (readTVar, readTVarIO)
+import Control.Exception (SomeException, bracket, throwIO)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import Dahdit.Midi.Osc (Datum (..), Packet)
+import Dahdit.Network (Conn (..), HostPort (..), resolveAddr, runDecoder, runEncoder, udpServerConn)
+import Data.Acquire (Acquire)
+import Data.Either (isRight)
+import Data.Foldable (for_)
+import Data.Map.Strict qualified as Map
+import Data.Ratio ((%))
+import Data.Sequence (Seq)
+import Data.Text qualified as T
+import Minipat.Dirt.Attrs (Attrs, attrsDefault)
+import Minipat.Dirt.Core (Domain (..), Env (..), Impl (..), St (..), advanceCycleSTM, logEvents, setPlaying, withData)
+import Minipat.Dirt.Logger (LogAction, logError, logInfo)
+import Minipat.Dirt.Osc (PlayEnv (..), PlayErr, convertTape, handshakePacket, playPacket)
+import Minipat.Dirt.Resources (Timed (..), acquireAwait, acquireLoop, relVarAcquire)
+import Minipat.Stream (streamRun)
+import Minipat.Time (Arc (..), CycleTime (..))
+import Nanotime (PosixTime, TimeDelta, addTime, threadDelayDelta, timeDeltaFromFracSecs)
+import Network.Socket qualified as NS
+
+data DirtEnv = DirtEnv
+  { deTargetHp :: !HostPort
+  , deListenHp :: !HostPort
+  , deOscTimeout :: !TimeDelta
+  }
+  deriving stock (Eq, Ord, Show)
+
+defaultDirtEnv :: DirtEnv
+defaultDirtEnv =
+  DirtEnv
+    { deTargetHp = HostPort (Just "127.0.0.1") 57120
+    , deListenHp = HostPort (Just "127.0.0.1") 57129
+    , deOscTimeout = timeDeltaFromFracSecs @Double 0.1
+    }
+
+data OscConn = OscConn
+  { ocTargetAddr :: !NS.SockAddr
+  , ocListenConn :: !(Conn NS.SockAddr)
+  }
+
+acqConn :: DirtEnv -> Acquire OscConn
+acqConn (DirtEnv targetHp listenHp _) = do
+  targetAddr <- liftIO (resolveAddr targetHp)
+  conn <- udpServerConn Nothing listenHp
+  pure (OscConn targetAddr conn)
+
+type DirtSt = St DirtEnv OscConn Attrs Packet
+
+dirtImpl :: Impl DirtEnv OscConn Attrs Packet
+dirtImpl =
+  Impl
+    { implSpawn = \logger dom rv de -> do
+        conn <- relVarAcquire rv (acqConn de)
+        genTask <- relVarAcquire rv (acqGenTask logger dom)
+        sendTask <- relVarAcquire rv (acqSendTask conn dom)
+        let tasks = Map.fromList [("gen", genTask), ("send", sendTask)]
+        pure (tasks, conn)
+    , implAddOrbit = attrsDefault "orbit" . DatumInt32 . fromInteger
+    }
+
+genEventsSTM :: Domain Attrs Packet -> PosixTime -> STM (PlayEnv, Either PlayErr (Seq (Timed Attrs)))
+genEventsSTM dom now = do
+  ahead <- readTVar (domAhead dom)
+  cps <- readTVar (domCps dom)
+  gpc <- readTVar (domGpc dom)
+  gcyc <- readTVar (domGenCycle dom)
+  let start = CycleTime (gcyc % gpc)
+      end = CycleTime ((gcyc + 1) % gpc)
+      arc = Arc start end
+  stream <- readTVar (domStream dom)
+  let tape = streamRun stream arc
+      origin = addTime now ahead
+      penv = PlayEnv origin start cps
+      mpevs = convertTape penv tape
+  pure (penv, mpevs)
+
+doGen :: LogAction -> Domain Attrs Packet -> PosixTime -> IO ()
+doGen logger dom now = do
+  mr <- atomically $ do
+    playing <- readTVar (domPlaying dom)
+    if playing
+      then fmap Just (genEventsSTM dom now)
+      else pure Nothing
+  case mr of
+    Nothing -> pure ()
+    Just (_, mpevs) ->
+      case mpevs of
+        Left err -> logError logger (T.pack ("Gen failed: " ++ show err))
+        Right pevs -> do
+          debug <- readTVarIO (domDebug dom)
+          when debug (logEvents logger dom pevs)
+          atomically $ do
+            advanceCycleSTM dom
+            for_ pevs (writeTQueue (domQueue dom) . fmap playPacket)
+
+acqGenTask :: LogAction -> Domain Attrs Packet -> Acquire (Async ())
+acqGenTask logger dom = acquireLoop (domAhead dom) (doGen logger dom)
+
+sendPacket :: OscConn -> Packet -> IO ()
+sendPacket (OscConn targetAddr (Conn _ enc)) = runEncoder enc targetAddr
+
+doSend :: OscConn -> Timed Packet -> IO ()
+doSend conn = sendPacket conn . timedVal
+
+acqSendTask :: OscConn -> Domain Attrs Packet -> Acquire (Async ())
+acqSendTask conn dom = acquireAwait (domPlaying dom) (domQueue dom) (doSend conn)
+
+withTimeout :: TimeDelta -> IO a -> IO (Either SomeException a)
+withTimeout td act = do
+  thread <- async act
+  _ <- forkFinally (threadDelayDelta td) (const (cancel thread))
+  waitCatch thread
+
+recvPacket :: DirtSt -> IO (Either SomeException Packet)
+recvPacket st = withData st $ \(OscConn _ (Conn dec _)) ->
+  withTimeout (deOscTimeout (envImpl (stEnv st))) $
+    runDecoder dec >>= either throwIO pure . snd
+
+-- | Handshake with SuperDirt
+-- On success set playing true; on error false
+handshake :: DirtSt -> IO ()
+handshake st = bracket acq rel (const (pure ()))
+ where
+  logger = stLogger st
+  acq = do
+    logInfo logger "Handshaking ..."
+    withData st (`sendPacket` handshakePacket)
+    recvPacket st
+  rel resp = do
+    let ok = isRight resp
+    if ok
+      then logInfo logger "... handshake succeeded"
+      else logError logger "... handshake FAILED"
+    setPlaying st ok
diff --git a/minipat-dirt/src/Minipat/Dirt/Prelude.hs b/minipat-dirt/src/Minipat/Dirt/Prelude.hs
index 87f4ff7..d7ea471 100644
--- a/minipat-dirt/src/Minipat/Dirt/Prelude.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Prelude.hs
@@ -1,9 +1,11 @@
 -- | Re-exports desirable modules for live coding
 module Minipat.Dirt.Prelude
-  ( module X
+  ( module Minipat.Dirt.Boot
+  , module Minipat.Dirt.Combinators
+  , module Minipat.Dirt.Params
   )
 where
 
-import Minipat.Dirt.Boot as X
-import Minipat.Dirt.Combinators as X
-import Minipat.Dirt.Params as X
+import Minipat.Dirt.Boot
+import Minipat.Dirt.Combinators
+import Minipat.Dirt.Params
diff --git a/minipat-dirt/src/Minipat/Dirt/Resources.hs b/minipat-dirt/src/Minipat/Dirt/Resources.hs
index ba9006a..7d1f035 100644
--- a/minipat-dirt/src/Minipat/Dirt/Resources.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Resources.hs
@@ -2,6 +2,7 @@ module Minipat.Dirt.Resources
   ( RelVar
   , relVarInit
   , relVarDispose
+  , relVarUse
   , relVarAcquire
   , withRelVar
   , acquireAsync
@@ -15,7 +16,7 @@ import Control.Concurrent.Async (Async, async, cancel)
 import Control.Concurrent.STM (atomically, retry)
 import Control.Concurrent.STM.TQueue (TQueue, peekTQueue, readTQueue, tryPeekTQueue)
 import Control.Concurrent.STM.TVar (TVar, readTVar, readTVarIO)
-import Control.Exception (Exception, bracket, mask, throwIO)
+import Control.Exception (Exception, bracket, mask, onException, throwIO)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource (InternalState, closeInternalState, createInternalState)
@@ -34,6 +35,11 @@ relVarInit = createInternalState
 relVarDispose :: RelVar -> IO ()
 relVarDispose = closeInternalState
 
+relVarUse :: (RelVar -> IO a) -> IO a
+relVarUse f = do
+  rv <- relVarInit
+  onException (f rv) (relVarDispose rv)
+
 relVarAcquire :: RelVar -> Acquire a -> IO a
 relVarAcquire rv (Acquire f) = mask $ \restore -> do
   Allocated a free <- f restore
diff --git a/minipat-dirt/src/Minipat/Dirt/Test.hs b/minipat-dirt/src/Minipat/Dirt/Test.hs
index 0f13c37..5705e01 100644
--- a/minipat-dirt/src/Minipat/Dirt/Test.hs
+++ b/minipat-dirt/src/Minipat/Dirt/Test.hs
@@ -1,90 +1,101 @@
-{-# LANGUAGE OverloadedStrings #-}
+-- {-# LANGUAGE OverloadedStrings #-}
 
+-- TODO Use these as the basis of some unit tests
 module Minipat.Dirt.Test where
 
-import Control.Concurrent.MVar (withMVar)
-import Control.Exception (throwIO)
-import Dahdit.Midi.Osc (Datum (..))
-import Data.Foldable (for_)
-import Data.Ratio ((%))
-import Data.Sequence (Seq)
-import Minipat.Classes (patFastBy)
-import Minipat.Dirt.Attrs (Attrs, attrsFromList)
-import Minipat.Dirt.Core
-  ( OscConn
-  , Resources (..)
-  , St (..)
-  , recvPacket
-  , sendPacket
-  , setOrbit
-  , setPlaying
-  , setTempo
-  , withSt
-  )
-import Minipat.Dirt.Osc (PlayEnv (..), PlayErr, convertTape, handshakePacket, playPacket)
-import Minipat.Dirt.Resources (Timed (..))
-import Minipat.Stream (Ev (..), tapeSingleton)
-import Minipat.Time (Arc (..), Span (..))
-import Nanotime (TimeLike (..), threadDelayDelta, timeDeltaFromFracSecs)
-
-sendHandshake :: OscConn -> IO ()
-sendHandshake conn = sendPacket conn handshakePacket
-
-sendPlay :: OscConn -> Either PlayErr (Seq (Timed Attrs)) -> IO ()
-sendPlay conn mpevs =
-  case mpevs of
-    Left err -> throwIO err
-    Right pevs ->
-      for_ pevs $ \pev -> do
-        let tp@(Timed tm pkt) = fmap playPacket pev
-        print tp
-        now <- currentTime
-        threadDelayDelta (diffTime now tm)
-        sendPacket conn pkt
-
-testHandshake :: IO ()
-testHandshake = do
-  putStrLn "handshake - initializing"
-  withSt $ \st -> do
-    putStrLn "sending handshake"
-    withMVar (stRes st) (sendHandshake . resConn)
-    putStrLn "listening"
-    resp <- recvPacket st
-    putStrLn "received"
-    print resp
-
-testPlay :: IO ()
-testPlay = do
-  putStrLn "play - initializing"
-  withSt $ \st -> do
-    dawn <- currentTime
-    putStrLn ("sending play @ " <> show dawn)
-    let cps = 1 % 2
-        penv = PlayEnv dawn 0 cps
-        arg =
-          convertTape penv $
-            tapeSingleton $
-              Ev (Span (Arc 0 1) (Just (Arc 0 1))) $
-                attrsFromList
-                  [ ("sound", DatumString "tabla")
-                  , ("orbit", DatumInt32 0)
-                  ]
-    withMVar (stRes st) (\res -> sendPlay (resConn res) arg)
-    putStrLn "done"
-
-testReal :: IO ()
-testReal = do
-  putStrLn "real - initializing"
-  withSt $ \st -> do
-    withMVar (stRes st) (sendHandshake . resConn)
-    let m =
-          attrsFromList
-            [ ("sound", DatumString "cpu")
-            , ("orbit", DatumInt32 0)
-            ]
-    setOrbit st 0 (patFastBy 4 (pure m))
-    setPlaying st True
-    threadDelayDelta (timeDeltaFromFracSecs @Double 6)
-    setTempo st 180
-    threadDelayDelta (timeDeltaFromFracSecs @Double 6)
-    setPlaying st False
+-- import Control.Concurrent.MVar (withMVar)
+-- import Control.Exception (bracket, throwIO)
+-- import Dahdit.Midi.Osc (Datum (..))
+-- import Data.Foldable (for_)
+-- import Data.Ratio ((%))
+-- import Data.Sequence (Seq)
+-- import Minipat.Classes (patFastBy)
+-- import Minipat.Dirt.Attrs (Attrs, attrsFromList)
+-- import Minipat.Dirt.Core
+--   ( OscConn
+--   , Resources (..)
+--   , St (..)
+--   , recvPacket
+--   , sendPacket
+--   , setOrbit
+--   , setPlaying
+--   , setTempo
+--   , DirtEnv
+--   , initSt
+--   , defaultEnv
+--   , defaultDirtEnv
+--   , disposeSt
+--   )
+-- import Minipat.Dirt.Logger (newLogger)
+-- import Minipat.Dirt.Osc (PlayEnv (..), PlayErr, convertTape, handshakePacket, playPacket)
+-- import Minipat.Dirt.Resources (Timed (..))
+-- import Minipat.Stream (Ev (..), tapeSingleton)
+-- import Minipat.Time (Arc (..), Span (..))
+-- import Nanotime (TimeLike (..), threadDelayDelta, timeDeltaFromFracSecs)
+--
+-- withSt :: (St DirtEnv -> IO a) -> IO a
+-- withSt f = do
+--   logger <- newLogger
+--   bracket (initSt logger (defaultEnv defaultDirtEnv)) disposeSt f
+--
+-- sendHandshake :: OscConn -> IO ()
+-- sendHandshake conn = sendPacket conn handshakePacket
+--
+-- sendPlay :: OscConn -> Either PlayErr (Seq (Timed Attrs)) -> IO ()
+-- sendPlay conn mpevs =
+--   case mpevs of
+--     Left err -> throwIO err
+--     Right pevs ->
+--       for_ pevs $ \pev -> do
+--         let tp@(Timed tm pkt) = fmap playPacket pev
+--         print tp
+--         now <- currentTime
+--         threadDelayDelta (diffTime now tm)
+--         sendPacket conn pkt
+--
+-- testHandshake :: IO ()
+-- testHandshake = do
+--   putStrLn "handshake - initializing"
+--   withSt $ \st -> do
+--     putStrLn "sending handshake"
+--     withMVar (stRes st) (sendHandshake . resConn)
+--     putStrLn "listening"
+--     resp <- recvPacket st
+--     putStrLn "received"
+--     print resp
+--
+-- testPlay :: IO ()
+-- testPlay = do
+--   putStrLn "play - initializing"
+--   withSt $ \st -> do
+--     dawn <- currentTime
+--     putStrLn ("sending play @ " <> show dawn)
+--     let cps = 1 % 2
+--         penv = PlayEnv dawn 0 cps
+--         arg =
+--           convertTape penv $
+--             tapeSingleton $
+--               Ev (Span (Arc 0 1) (Just (Arc 0 1))) $
+--                 attrsFromList
+--                   [ ("sound", DatumString "tabla")
+--                   , ("orbit", DatumInt32 0)
+--                   ]
+--     withMVar (stRes st) (\res -> sendPlay (resConn res) arg)
+--     putStrLn "done"
+--
+-- testReal :: IO ()
+-- testReal = do
+--   putStrLn "real - initializing"
+--   withSt $ \st -> do
+--     withMVar (stRes st) (sendHandshake . resConn)
+--     let m =
+--           attrsFromList
+--             [ ("sound", DatumString "cpu")
+--             , ("orbit", DatumInt32 0)
+--             ]
+--     setOrbit st 0 (patFastBy 4 (pure m))
+--     setPlaying st True
+--     threadDelayDelta (timeDeltaFromFracSecs @Double 6)
+--     setTempo st 180
+--     threadDelayDelta (timeDeltaFromFracSecs @Double 6)
+--     setPlaying st False