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 to quit" _ <- getLine return ()