Main.hs

import           Blaze.ByteString.Builder (Builder)
import           Blaze.ByteString.Builder.Char8 (fromText)
import           Control.Concurrent (forkIO, threadDelay)
import           Control.Concurrent.Chan (Chan, newChan, writeList2Chan)
import           Control.Monad (void)
import           Data.CQRS
import           Data.CQRS.EventStore.Backend.Sqlite3 (openSqliteEventStore)
import qualified Data.Set as S
import           Data.Text (Text)
import qualified Data.Text as T
import           Database.HDBC (IConnection)
import           Database.HDBC.Sqlite3 (connectSqlite3)
import           Network.Wai.EventSource (ServerEvent(..))
import           Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)
import           Prelude hiding (mapM)

import           CQRSExample.Command
import           CQRSExample.Events
import           CQRSExample.Instances ()
import           CQRSExample.Query
import           CQRSExample.Wai
import           CQRSExample.WaiAuth

-- Source of refresh events to the browser.
eventSourcingThread :: IConnection c => c -> Chan ServerEvent -> EventStore Event -> IO ()
eventSourcingThread connection jsonEvents eventStore = do
  loop
    where
      loop = do
        putStrLn "Sourcing events..."
        refresh <- reactToUnseenEvents connection eventStore
        -- Issue refresh events to browser.
        writeList2Chan jsonEvents (map (toServerEvent . fromText . convertRefresh) $ S.toList refresh)
        -- Wait 1 second
        threadDelay 1000000
        -- Go again.
        loop
      -- Convert refresh values to JSON for browser.
      convertRefresh :: Refresh -> Text
      convertRefresh RefreshProjects = "refresh-projects"
      convertRefresh RefreshTasks = "refresh-tasks"
      convertRefresh RefreshTimesheet = "refresh-timesheet"
      -- Convert a value to a server event.
      toServerEvent :: Builder -> ServerEvent
      toServerEvent j = ServerEvent Nothing Nothing [j]

-- Check user.
checkUser :: IConnection c => c -> String -> String -> IO (Maybe AuthenticatedUser)
checkUser c u p = do
  user <- qFindUser c $ T.pack u
  case user of
    Just (userId, p') ->
      return $ if p == T.unpack p' then Just (AuthenticatedUser u userId) else Nothing
    Nothing ->
      return Nothing

-- Start serving the application.
startServing :: IO ()
startServing =
  do
    let queryDbFile = "query.db"
    let sqliteFile = "example.db"

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

    -- Queue of json events to send to browser.
    jsonEvents <- newChan

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

    -- Web serving thread.
    let mySettings = defaultSettings { settingsPort = 8000 }
    void $ forkIO $ do
      withEventStore (openSqliteEventStore sqliteFile) $ \eventStore ->
        runSettings mySettings $
        basicAuth "Clockwork" (checkUser conn) $
        exampleWaiApplication conn eventStore jsonEvents

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

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