cqrs-example-0.5.0: src/Main.hs

import Control.Concurrent (forkIO, threadDelay)
import Control.Monad.Trans.Class (lift)
import Data.CQRS
import Data.CQRS.EventStore.Backend.Sqlite3
import Data.IORef (newIORef, readIORef)
import Aggregates
import Events
import Instances ()
import Query

sqliteFile :: String
sqliteFile = "example.db"

eventSourcingThread :: EventStore Event -> IO ()
eventSourcingThread eventStore = do
  qsRef <- newIORef emptyQueryState
  loop qsRef
    where
      loop qsRef = do
        putStrLn "Sourcing events..."
        updateQueryStateRef qsRef eventStore
        qs <- readIORef qsRef
        putStrLn $ " => qs: " ++ show qs
        -- Wait 1 second
        threadDelay 1000000
        -- Go again.
        loop qsRef


test1 :: IO ()
test1 =
  do
    -- Start sourcing events.
    _ <- forkIO $ do
      withEventStore (openSqliteEventStore sqliteFile) eventSourcingThread

    -- Do a few things
    withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do
      runTransactionT eventStore $ do
        -- Create new project.
        projectId :: GUID Project <- lift $ newGUID
        (projectRef, _) <- getAggregateRoot projectId
        publishEvent projectRef $ ProjectCreated "my project"

        -- Add a couple of tasks
        taskId1 :: GUID Task <- lift $ newGUID
        (taskRef1, _) <- getAggregateRoot taskId1
        publishEvent taskRef1 $ TaskAdded projectId "tweak knob"

        taskId2 :: GUID Task <- lift $ newGUID
        (taskRef2, _) <- getAggregateRoot taskId2
        publishEvent taskRef2 $ TaskAdded projectId "pull lever"

        -- Rename project.
        publishEvent projectRef $ ProjectRenamed "old project"


main :: IO ()
main = do
  putStrLn "Running test1..."
  test1
  putStrLn "Press <Enter> to quit"
  _ <- getLine
  return ()