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