cqrs-example-0.6.0: src/Main.hs

import           Control.Concurrent (forkIO, threadDelay)
import           Control.Monad (liftM)
import           Control.Monad.Trans.Class (lift)
import           Data.Aeson (ToJSON, encode)
import           Data.CQRS
import           Data.CQRS.GUID (hexEncode)
import           Data.CQRS.EventStore.Backend.Sqlite3
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Time (fromGregorian)
import           Database.SQLite3 (Database)
import           Aggregates
import           Events
import           Instances ()
import           Query
import           Happstack.Lite

sqliteFile :: String
sqliteFile = "example.db"

eventSourcingThread :: Database -> EventStore Event -> IO ()
eventSourcingThread queryDb eventStore = do
  loop
    where
      loop = do
        putStrLn "Sourcing events..."
        updateQueryStateRef queryDb eventStore
        -- Wait 1 second
        threadDelay 1000000
        -- Go again.
        loop

-- Serve JSON ok response.
okJson :: ToJSON a => a -> ServerPart Response
okJson a = ok $ toResponseBS "text/json" $ encode a

-- Serve JSON project list.
projectsJson :: Database -> ServerPart Response
projectsJson queryDb = do
  p <- liftM (map f) $ lift $ qProjectList queryDb
  okJson $ p
  where
    f (g,pn,psd) =
      M.fromList [ (T.pack "id"        , TE.decodeUtf8 $ hexEncode g)
                 , (T.pack "name"      , pn)
                 , (T.pack "short_desc", psd)
                 ]

-- Serve JSON task list.
tasksJson :: Database -> ServerPart Response
tasksJson queryDb = do
  p <- liftM (map f) $ lift $ qTaskList queryDb
  okJson $ p
  where
    f (g,tsd) =
      M.fromList [ (T.pack "id"               , TE.decodeUtf8 $ hexEncode g)
                 , (T.pack "short_description", tsd)
                 ]

-- Serve JSON data.
jsonPart :: Database -> ServerPart Response
jsonPart queryDb =
  msum
  [ dir "projects" $ projectsJson queryDb
  , dir "tasks" $ tasksJson queryDb
  , dir "time-sheet" $ okJson ([ ] :: [String])
  ]

-- Serve.
myApp :: Database -> ServerPart Response
myApp queryDb = msum
  [ dir "js" $ serveDirectory EnableBrowsing [ ] "static/js"
  , dir "css" $ serveDirectory EnableBrowsing [ ] "static/css"
  , dir "json" $ jsonPart queryDb
  , serveDirectory EnableBrowsing [ "index.html" ] "static"
  ]

--
test1 :: IO ()
test1 =
  do
    let queryDbFile = "query.db"
    -- Start sourcing events.
    _ <- forkIO $ do
      queryDb <- initializeQueryDatabase queryDbFile
      withEventStore (openSqliteEventStore sqliteFile) $ eventSourcingThread queryDb

    -- Web serving thread.
    _ <- forkIO $ do
      queryDb <- initializeQueryDatabase queryDbFile
      serve Nothing $ myApp queryDb

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

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

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

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

        -- Create user.
        userId1 <- lift $ newGUID
        (userRef1, _ :: User) <- getAggregateRoot userId1
        publishEvent userRef1 $ UserCreated "bardur" "Bardur" "Arantsson"

        -- Record time for task #2.
        workUnitId1 <- lift $ newGUID
        publishEvent taskRef2 $ RecordedWorkUnit workUnitId1 (fromGregorian 2011 12 01) 3 "found the lever to pull" userId1


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