|
module AppTicket ( |
|
AppTicketEnv (..), |
|
AppTicket (..), |
|
HasAppTicket (..), |
|
runAppTicket, |
|
createTicketHandler, |
|
getTicketHandler, |
|
getTicketProject, |
|
) where |
|
|
|
import Relude |
|
|
|
import Api ( |
|
CreateTicketRequest, |
|
CreateTicketResponse, |
|
GetTicketResponse, |
|
ProjectId, |
|
TicketId, |
|
) |
|
import App (HasApp (..)) |
|
import AppAuthenticated (HasAppAuthenticated (..)) |
|
import AppProject ( |
|
AppProject (..), |
|
AppProjectEnv, |
|
HasAppProject (..), |
|
Project (..), |
|
findProjectById, |
|
getProjectOrganization, |
|
) |
|
import Authentication (HasAuth (..), getUserId) |
|
import Control.Exception (throwIO) |
|
import Control.Monad.Logger (MonadLogger (..)) |
|
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=)) |
|
import Database (HasDatabase (..), query, runDatabase) |
|
import Logging (HasLogFunc (..), monadLoggerLogImpl) |
|
import Organization (HasOrganizationService (..), Organization (organizationId)) |
|
import Servant (ServerError (..), err404, err500) |
|
import Tracing (HasTracing (..), traced) |
|
|
|
data AppTicketEnv = AppTicketEnv |
|
{ appProjectEnv :: AppProjectEnv |
|
, ticketProject :: Project |
|
} |
|
|
|
newtype AppTicket a = AppTicket |
|
{ unAppTicket :: ReaderT AppTicketEnv IO a |
|
} |
|
deriving newtype |
|
( Functor |
|
, Applicative |
|
, Monad |
|
, MonadIO |
|
, MonadReader AppTicketEnv |
|
) |
|
|
|
instance MonadLogger AppTicket where |
|
monadLoggerLog = monadLoggerLogImpl |
|
|
|
class (HasAppProject env) => HasAppTicket env where |
|
getAppTicket :: env -> AppTicketEnv |
|
|
|
instance HasAppTicket AppTicketEnv where |
|
getAppTicket = identity |
|
|
|
instance HasAppProject AppTicketEnv where |
|
getAppProject = appProjectEnv |
|
|
|
instance HasAppAuthenticated AppTicketEnv where |
|
getAppAuthenticated = getAppAuthenticated . getAppProject |
|
|
|
instance HasAuth AppTicketEnv where |
|
getAuth = getAuth . getAppAuthenticated |
|
|
|
instance HasOrganizationService AppTicketEnv where |
|
getOrganizationService = getOrganizationService . getAppAuthenticated |
|
|
|
instance HasApp AppTicketEnv where |
|
getApp = getApp . getAppAuthenticated . getAppProject |
|
|
|
instance HasLogFunc AppTicketEnv where |
|
getLogFunc = getLogFunc . getApp |
|
|
|
instance HasDatabase AppTicketEnv where |
|
getDatabase = getDatabase . getApp |
|
|
|
instance HasTracing AppTicketEnv where |
|
getTracing = getTracing . getApp |
|
|
|
runAppTicket |
|
:: ProjectId |
|
-> AppTicket a |
|
-> AppProject a |
|
runAppTicket projectId action = do |
|
let projectNotFound :: AppProject Project |
|
projectNotFound = |
|
liftIO $ throwIO $ err404 {errBody = "Project not found"} |
|
maybeProject <- runDatabase (findProjectById projectId) |
|
project <- maybe projectNotFound pure maybeProject |
|
let mapEnv appProjectEnv = |
|
AppTicketEnv |
|
{ appProjectEnv = appProjectEnv |
|
, ticketProject = project |
|
} |
|
AppProject $ withReaderT mapEnv (unAppTicket action) |
|
|
|
createTicketHandler :: CreateTicketRequest -> AppTicket CreateTicketResponse |
|
createTicketHandler ticketName = traced "create_ticket" $ do |
|
userId <- getUserId |
|
organizationId <- organizationId <$> getProjectOrganization |
|
projectId <- projectId <$> getTicketProject |
|
_ <- |
|
runDatabase |
|
$ query |
|
"insert into tickets (name, project_id) values (?, ?) returning id" |
|
(ticketName, projectId) |
|
logInfo |
|
$ "created ticket" |
|
:# [ "user_id" .= userId |
|
, "organization_id" .= organizationId |
|
, "project_id" .= projectId |
|
] |
|
liftIO $ throwIO $ err500 {errBody = "Not implemented"} |
|
|
|
getTicketHandler :: TicketId -> AppTicket GetTicketResponse |
|
getTicketHandler ticketId = traced "get_ticket" $ do |
|
userId <- getUserId |
|
organizationId <- organizationId <$> getProjectOrganization |
|
projectId <- projectId <$> getTicketProject |
|
_ <- |
|
runDatabase |
|
$ query |
|
"select id, name from tickets where id = ?" |
|
ticketId |
|
logInfo |
|
$ "fetched ticket" |
|
:# [ "user_id" .= userId |
|
, "organization_id" .= organizationId |
|
, "project_id" .= projectId |
|
] |
|
liftIO $ throwIO $ err500 {errBody = "Not implemented"} |
|
|
|
getTicketProject |
|
:: (MonadReader env m, HasAppTicket env) => m Project |
|
getTicketProject = |
|
asks (ticketProject . getAppTicket) |