Wai.hs

module CQRSExample.Wai
       ( AuthenticatedUser(..)
       , exampleWaiApplication
       ) where

import           Control.Concurrent.Chan (Chan)
import           Control.Monad (void)
import           Control.Monad.Trans.Class (lift)
import           Data.Aeson (ToJSON(..), encode)
import           Data.CQRS
import           Data.CQRS.GUID (hexEncode)
import           Data.Text (Text)
import           Database.HDBC (IConnection)
import           Network.HTTP.Types (status200, status404, status400, status501, StdMethod(..), parseMethod)
import           Network.Wai (Application, Request, Response, pathInfo, responseLBS, requestMethod)
import           Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import           Network.Wai.EventSource (eventSourceApp, ServerEvent(..))
import           Prelude hiding (mapM)

import           CQRSExample.Aggregates (UserId)
import           CQRSExample.Command
import           CQRSExample.Events
import           CQRSExample.Instances ()
import           CQRSExample.Json
import           CQRSExample.WaiParameters

data AuthenticatedUser = -- TODO: This doesn't really belong here.
  AuthenticatedUser { auUserName :: String
                    , auUserId :: UserId
                    }

exampleWaiApplication :: IConnection c => c -> EventStore Event -> Chan ServerEvent -> AuthenticatedUser -> Application
exampleWaiApplication conn eventStore serverEvents user req =
  case parseMethod (requestMethod req) of
    Right method -> route method
    Left _ -> return $ responseLBS status501 [] ""

  where

    userId = auUserId user

    route method = do
      case (method,pathInfo req) of
        (GET , "events" : _)              -> eventSourceApp serverEvents req
        (_   , "json" : "projects" : _)   -> runParameters (appJsonProjects method) req
        (_   , "json" : "tasks" : _)      -> runParameters (appJsonTasks method) req
        (_   , "json" : "time-sheet" : _) -> runParameters (appJsonTimesheet method) req
        (_   , "json" : "stars" : _)      -> runParameters (appStars method) req
        (GET , _)                         -> staticApp defaultFileServerSettings req
        _                                 -> return notFound

    -- Projects
    appJsonProjects GET =
      lift $ lift $ qProjectListJson conn >>= returnJson
    appJsonProjects POST = do
      pn <- requireText "name"
      pd <- requireText "shortDescription"
      pid <- lift $ lift $ runTransactionT eventStore $ do
        createProject pn pd
      returnJson $ hexEncode pid
    appJsonProjects _ = badRequest

    -- Tasks
    appJsonTasks GET = do
      mProjectId <- lookGUID "projectId"
      lift $ lift $ qTaskListJson userId mProjectId conn >>= returnJson
    appJsonTasks POST = do
      pid <- requireGUID "projectId"
      estimate <- requireDuration "estimate"
      tsd <- requireText "shortDescription"
      tid <- lift $ lift $ runTransactionT eventStore $ do
        createTask pid tsd estimate userId
      returnJson $ hexEncode tid
    appJsonTasks _ = badRequest

    -- Timesheet
    appJsonTimesheet GET = do
      fromDate <- requireDay "fromDate"
      toDate <- requireDay "toDate"
      lift $ lift $ qTimesheetJson fromDate toDate userId conn >>= returnJson
    appJsonTimesheet POST = do
      taskId <- requireGUID "taskId"
      duration <- requireDuration "duration"
      comment <- requireText "comment"
      date <- requireDay "date"
      lift $ lift $ runTransactionT eventStore $ do
        void $ logWork taskId userId date duration comment
      returnJson ("OK" :: Text)
    appJsonTimesheet _ = badRequest

    -- Stars
    appStars POST = do
      taskId <- requireGUID "taskId"
      starred <- requireBool "starred"
      lift $ lift $ runTransactionT eventStore $ void $ do
        case starred of
          True  -> starTask taskId userId
          False -> unstarTask taskId userId
      returnJson ("OK" :: Text)
    appStars _ = badRequest

    badRequest = return $ responseLBS status400 [] ""

returnJson :: Monad m => ToJSON a => a -> m Response
returnJson a = return $ responseLBS status200 [("Content-Type", "text/json")] $ encode a

notFound :: Response
notFound = responseLBS status404 [("Content-Type", "text/plain")] "404 - Not Found"