Routing.hs

module CQRSExample.Routing
       ( toServerEvent
       , routes
       ) where

import           Blaze.ByteString.Builder.Char8 (fromLazyText)
import           Control.Monad (forever, void)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Class (lift)
import           Control.Concurrent.STM (atomically, TChan)
import           Control.Concurrent.STM.TChan (dupTChan, readTChan)
import           Control.Concurrent.STM.TVar (TVar)
import           Data.Aeson.Types (ToJSON(..), Value(..))
import qualified Data.Aeson.Encode as AE
import           Data.Conduit (yield)
import           Data.CQRS.Command (GUID, EventStoreBackend, Repository, runUnitOfWorkT)
import           Data.CQRS.GUID (hexDecode)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import           Network.Wai.EventSource (ServerEvent(..), sourceToSource)
import           Network.Wai.Middleware.Static (staticPolicy, addBase)
import           Web.Scotty (ScottyM, get, source, header, post, json, middleware, param, redirect, Parsable(..))

import qualified CQRSExample.Command as C
import           CQRSExample.Events
import           CQRSExample.Instances ()
import           CQRSExample.Json
import           CQRSExample.Query (QueryState)

-- Convert a JSON value to a server event.
toServerEvent :: ToJSON j => j -> ServerEvent
toServerEvent j = ServerEvent Nothing Nothing builders
    where builders = [fromLazyText $ TLB.toLazyText $ AE.fromValue $ toJSON j]

-- Need parsing for GUIDs
instance Parsable GUID where
    parseParam text =
      case hexDecode $ TE.encodeUtf8 $ TL.toStrict text of
        Just g -> Right g
        Nothing -> Left "Could not parse GUID"

-- Example application
routes :: (EventStoreBackend b) => TVar QueryState -> Repository Event b -> TChan ServerEvent -> ScottyM ()
routes qs repository serverEvents = do
  -- Middleware to serve static files
  middleware $ staticPolicy (addBase "static")

  -- Redirect to index
  get "/" $ do
    redirect "/index.html"

  -- Actions
  post "/tasks/archive-completed" $ do
    run $ C.archiveCompletedTasks qs

  post "/tasks/complete" $ do
    tid <- param "id"
    run $ C.completeTask tid

  post "/tasks/reopen" $ do
    tid <- param "id"
    run $ C.reopenTask tid

  get "/tasks" $ do
    tasks <- liftIO $ qTaskListJson qs
    json tasks

  post "/tasks" $ do
    title <- fmap T.pack $ param "title"
    run $ C.createTask title

  -- Notifications
  get "/events" $ do
    header "Content-Type" "text/event-stream"
    source $ sourceToSource $ do
      chan <- lift $ lift $ atomically $ dupTChan serverEvents
      forever $ do
        e <- lift $ lift $ atomically $ readTChan chan
        yield e

  where
    run unitOfWork = do
        void $ liftIO $ runUnitOfWorkT repository $ unitOfWork
        json Null