Main.hs

import           Control.Concurrent (forkIO, threadDelay)
import           Control.Monad (void, liftM)
import           Data.CQRS
import           Data.CQRS.EventStore.Backend.Sqlite3 (openSqliteEventStore)
import           Data.Foldable (foldMap)
import qualified Data.Text as T
import           Database.HDBC (IConnection)
import           Database.HDBC.Sqlite3 (connectSqlite3)
import           Happstack.Lite
import           CQRSExample.Command (siteInitialization)
import           CQRSExample.Controller.Auth
import           CQRSExample.Events
import           CQRSExample.Instances ()
import           CQRSExample.Json (jsonServerPart)
import           CQRSExample.Query

sqliteFile :: String
sqliteFile = "example.db"

eventSourcingThread :: IConnection c => c -> EventStore Event -> IO ()
eventSourcingThread connection eventStore = do
  loop
    where
      loop = do
        putStrLn "Sourcing events..."
        reactToUnseenEvents connection eventStore
        -- Wait 1 second
        threadDelay 1000000
        -- Go again.
        loop

-- Check user.
checkUser :: IConnection c => c -> String -> String -> IO Bool
checkUser c u p = do
  p' <- liftM (foldMap T.unpack) $ qFindUserPassword c (T.pack u)
  return $ (==) p p'

-- Serve.
myApp :: IConnection c => c -> EventStore Event -> ServerPart Response
myApp conn eventStore = msum
  [ dir "js" $ serveDirectory EnableBrowsing [ ] "static/js"
  , dir "css" $ serveDirectory EnableBrowsing [ ] "static/css"
  , dir "json" $ basicAuth "Restricted Area" (checkUser conn) $ jsonServerPart conn eventStore
  , serveDirectory EnableBrowsing [ "index.html" ] "static"
  ]

--
test1 :: IO ()
test1 =
  do
    let queryDbFile = "query.db"

    -- Connect to query database
    conn <- connectSqlite3 queryDbFile
    setupQueryDatabase conn  -- Perform any necessary setup.

    -- TODO: Should really do a "disconnect" too.

    -- Start sourcing events.
    _ <- forkIO $ do
      withEventStore (openSqliteEventStore sqliteFile) $ do
        eventSourcingThread conn

    -- Web serving thread.
    void $ forkIO $ do
      withEventStore (openSqliteEventStore sqliteFile) $ \eventStore ->
        serve Nothing $ myApp conn eventStore

    -- Perform site initialization if necessary.
    withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do
      runTransactionT eventStore $ do
        void $ siteInitialization

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