Query.hs

module CQRSExample.Query
       ( QueryM
       , QueryState
       , QTaskState(..)
       , newQueryState
       , runQuery
       , qCompletedTaskIdList
       , qTaskList
       , reactToEvent
       ) where

import           Control.Concurrent.STM (atomically)
import           Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar)
import           Control.DeepSeq (NFData(..), ($!!))
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import           Data.CQRS.Query (GUID, PersistedEvent(..))
import           Data.Data (Data)
import           Data.DeriveTH (derive, makeNFData)
import qualified Data.List as L
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.Text (Text)
import           Data.Typeable (Typeable)

import           CQRSExample.Aggregates ()
import           CQRSExample.Events (Event(..), TaskEvent(..))

-- Tasks.
data QTask =
    QTask { qTaskId :: GUID
          , qTaskTitle :: Text
          , qTaskState :: QTaskState }
    deriving (Data, Typeable, Ord, Eq, Show)

data QTaskState = QTaskOpen
                | QTaskCompleted
                | QTaskArchived
                  deriving (Data, Typeable, Ord, Eq, Show)

-- Queryable state.
data QueryState = QueryState
    { qTasks :: Map GUID QTask
    } deriving (Show)

-- Need NFData instances for deep evaluation.
$(derive makeNFData ''QTaskState)
$(derive makeNFData ''QTask)
$(derive makeNFData ''QueryState)

-- Query monad.
type QueryM a = ReaderT (TVar QueryState) IO a

-- Create query state.
newQueryState :: QueryState
newQueryState = QueryState { qTasks = M.empty }

-- runQuery
runQuery :: TVar QueryState -> QueryM a -> IO a
runQuery qs q = runReaderT q qs

-- Run query against the current state and return the result.
qRunQ :: QueryM QueryState
qRunQ = do
  qsr <- ask
  lift $ atomically $ readTVar qsr

-- Query the task list
qTaskList :: QueryM [(GUID, Text, QTaskState)]
qTaskList = do
  tasks <- fmap qTasks qRunQ
  return $ map f $ filter p $ L.sortBy sf $ M.elems tasks
  where
    f t = (qTaskId t, qTaskTitle t, qTaskState t)
    sf (QTask _ title1 _) (QTask _ title2 _) = compare title1 title2
    p (QTask _ _ QTaskOpen) = True
    p (QTask _ _ QTaskCompleted) = True
    p (QTask _ _ QTaskArchived) = False

qCompletedTaskIdList :: QueryM [GUID]
qCompletedTaskIdList = do
  tasks <- fmap qTasks qRunQ
  return $ map f $ filter p $ M.elems tasks
    where
      f (QTask i _ _) = i
      p (QTask _ _ QTaskCompleted) = True
      p (QTask _ _ QTaskOpen) = False
      p (QTask _ _ QTaskArchived) = False

reactToEvent :: PersistedEvent Event -> QueryM ()
reactToEvent ev = do
  let e = peEvent ev
  lift $ putStrLn $ "guid: " ++ show g ++ " event: " ++ show e
  qsr <- ask
  -- Update the query state
  lift $ atomically $ do
    qs0 <- readTVar qsr
    writeTVar qsr $!! react e $!! qs0

  where
    g = peAggregateGUID ev

    reactTask (TaskAdded title) =
        M.insert g (QTask g title QTaskOpen)
    reactTask TaskCompleted =
        M.adjust (\task -> task { qTaskState = QTaskCompleted }) g
    reactTask TaskReopened =
        M.adjust (\task -> task { qTaskState = QTaskOpen }) g
    reactTask TaskArchived =
        M.adjust (\task -> task { qTaskState = QTaskArchived }) g

    react (TaskEvent e) qs =
        qs { qTasks = reactTask e $ qTasks qs }