{- This file is part of Vervis. - - Written in 2016 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} module Vervis.Handler.Ticket ( getTicketsR , postTicketsR , getTicketNewR , getTicketR , putTicketR , deleteTicketR , postTicketR , getTicketEditR , postTicketCloseR , postTicketOpenR , postTicketClaimR , postTicketUnclaimR , getTicketAssignR , postTicketAssignR , postTicketUnassignR , getTicketDiscussionR , postTicketDiscussionR , getTicketMessageR , postTicketMessageR , getTicketTopReplyR , getTicketReplyR ) where import Prelude import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (logWarn) import Data.Default.Class (def) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Time.Calendar (Day (..)) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Traversable (for) import Database.Esqueleto hiding ((==.), (=.), (+=.), update) import Database.Persist import Text.Blaze.Html (Html, toHtml) import Yesod.Auth (requireAuthId, maybeAuthId) import Yesod.Core (defaultLayout) import Yesod.Core.Handler (setMessage, redirect, lookupPostParam, notFound) import Yesod.Form.Functions (runFormGet, runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Data.Text as T (filter, intercalate, pack) import qualified Database.Esqueleto as E ((==.)) import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Handler.Discussion import Vervis.MediaType (MediaType (Markdown)) import Vervis.Model import Vervis.Model.Ident import Vervis.Render (renderSourceT) import Vervis.Settings (widgetFile) import Vervis.TicketFilter (filterTickets) import Vervis.Time (showDate) import Vervis.Widget.Discussion (discussionW) import Vervis.Widget.Sharer (personLinkW) getTicketsR :: ShrIdent -> PrjIdent -> Handler Html getTicketsR shar proj = do ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm let tf = case filtResult of FormSuccess filt -> filt FormMissing -> def FormFailure l -> error $ "Ticket filter form failed: " ++ show l rows <- runDB $ select $ from $ \ (sharer, project, ticket) -> do where_ $ filterTickets tf ticket $ sharer ^. SharerIdent E.==. val shar &&. project ^. ProjectSharer E.==. sharer ^. SharerId &&. project ^. ProjectIdent E.==. val proj &&. ticket ^. TicketProject E.==. project ^. ProjectId orderBy [asc $ ticket ^. TicketNumber] return ( ticket ^. TicketNumber , sharer , ticket ^. TicketTitle , ticket ^. TicketDone ) defaultLayout $(widgetFile "ticket/list") postTicketsR :: ShrIdent -> PrjIdent -> Handler Html postTicketsR shar proj = do ((result, widget), enctype) <- runFormPost newTicketForm case result of FormSuccess nt -> do author <- requireAuthId now <- liftIO getCurrentTime tnum <- runDB $ do Entity pid project <- do Entity sid _sharer <- getBy404 $ UniqueSharer shar getBy404 $ UniqueProject proj sid update pid [ProjectNextTicket +=. 1] let discussion = Discussion { discussionNextMessage = 1 } did <- insert discussion let ticket = Ticket { ticketProject = pid , ticketNumber = projectNextTicket project , ticketCreated = now , ticketCreator = author , ticketTitle = ntTitle nt , ticketDesc = ntDesc nt , ticketAssignee = Nothing , ticketDone = False , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 , ticketCloser = author , ticketDiscuss = did } insert_ ticket return $ ticketNumber ticket setMessage "Ticket created." redirect $ TicketR shar proj tnum FormMissing -> do setMessage "Field(s) missing." defaultLayout $(widgetFile "ticket/new") FormFailure _l -> do setMessage "Ticket creation failed, see errors below." defaultLayout $(widgetFile "ticket/new") getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html getTicketNewR shar proj = do ((_result, widget), enctype) <- runFormPost newTicketForm defaultLayout $(widgetFile "ticket/new") getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketR shar proj num = do mpid <- maybeAuthId (author, massignee, closer, ticket) <- runDB $ do ticket <- do Entity s _ <- getBy404 $ UniqueSharer shar Entity p _ <- getBy404 $ UniqueProject proj s Entity _ t <- getBy404 $ UniqueTicket p num return t author <- do person <- get404 $ ticketCreator ticket get404 $ personIdent person massignee <- for (ticketAssignee ticket) $ \ apid -> do person <- get404 apid sharer <- get404 $ personIdent person return (sharer, fromMaybe False $ (== apid) <$> mpid) closer <- if ticketDone ticket then do person <- get404 $ ticketCloser ticket get404 $ personIdent person else return author return (author, massignee, closer, ticket) let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket discuss = discussionW (return $ ticketDiscuss ticket) (TicketTopReplyR shar proj num) (TicketReplyR shar proj num) defaultLayout $(widgetFile "ticket/one") putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html putTicketR shar proj num = do Entity tid ticket <- runDB $ do Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid getBy404 $ UniqueTicket pid num ((result, widget), enctype) <- runFormPost $ editTicketContentForm ticket case result of FormSuccess ticket' -> do runDB $ replace tid ticket' setMessage "Ticket updated." redirect $ TicketR shar proj num FormMissing -> do setMessage "Field(s) missing." defaultLayout $(widgetFile "ticket/edit") FormFailure _l -> do setMessage "Ticket update failed, see errors below." defaultLayout $(widgetFile "ticket/edit") deleteTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html deleteTicketR shar proj num = --TODO: I can easily implement this, but should it even be possible to --delete tickets? error "Not implemented" postTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketR shar proj num = do mmethod <- lookupPostParam "_method" case mmethod of Just "PUT" -> putTicketR shar proj num Just "DELETE" -> deleteTicketR shar proj num _ -> notFound getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketEditR shar proj num = do Entity _tid ticket <- runDB $ do Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid getBy404 $ UniqueTicket pid num ((_result, widget), enctype) <- runFormPost $ editTicketContentForm ticket defaultLayout $(widgetFile "ticket/edit") postTicketCloseR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketCloseR shr prj num = do pid <- requireAuthId now <- liftIO getCurrentTime succ <- runDB $ do Entity tid ticket <- do Entity s _ <- getBy404 $ UniqueSharer shr Entity p _ <- getBy404 $ UniqueProject prj s getBy404 $ UniqueTicket p num if ticketDone ticket then return False else do update tid [ TicketAssignee =. Nothing , TicketDone =. True , TicketClosed =. now , TicketCloser =. pid ] return True setMessage $ if succ then "Ticket closed." else "Ticket is already closed." redirect $ TicketR shr prj num postTicketOpenR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketOpenR shr prj num = do pid <- requireAuthId now <- liftIO getCurrentTime succ <- runDB $ do Entity tid ticket <- do Entity s _ <- getBy404 $ UniqueSharer shr Entity p _ <- getBy404 $ UniqueProject prj s getBy404 $ UniqueTicket p num if ticketDone ticket then do update tid [ TicketDone =. False , TicketCloser =. ticketCreator ticket ] return True else return False setMessage $ if succ then "Ticket reopened" else "Ticket is already open." redirect $ TicketR shr prj num postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketClaimR shr prj num = do pid <- requireAuthId mmsg <- runDB $ do Entity tid ticket <- do Entity s _ <- getBy404 $ UniqueSharer shr Entity p _ <- getBy404 $ UniqueProject prj s getBy404 $ UniqueTicket p num case (ticketDone ticket, ticketAssignee ticket) of (True, _) -> return $ Just "The ticket is closed. Can’t claim closed tickets." (False, Just _) -> return $ Just "The ticket is already assigned to someone." (False, Nothing) -> do update tid [TicketAssignee =. Just pid] return Nothing setMessage $ fromMaybe "The ticket is now assigned to you." mmsg redirect $ TicketR shr prj num postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketUnclaimR shr prj num = do pid <- requireAuthId mmsg <- runDB $ do Entity tid ticket <- do Entity s _ <- getBy404 $ UniqueSharer shr Entity p _ <- getBy404 $ UniqueProject prj s getBy404 $ UniqueTicket p num case ((== pid) <$> ticketAssignee ticket, ticketDone ticket) of (Nothing, _) -> return $ Just "The ticket is already unassigned." (Just False, _) -> return $ Just "The ticket is assigned to someone else." (Just True, True) -> do $logWarn "Found a closed claimed ticket, this is invalid" return $ Just "The ticket is closed. Can’t unclaim closed tickets." (Just True, False) -> do update tid [TicketAssignee =. Nothing] return Nothing setMessage $ fromMaybe "The ticket is now unassigned." mmsg redirect $ TicketR shr prj num getTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketAssignR shr prj num = do vpid <- requireAuthId (jid, Entity tid ticket) <- runDB $ do Entity s _ <- getBy404 $ UniqueSharer shr Entity j _ <- getBy404 $ UniqueProject prj s et <- getBy404 $ UniqueTicket j num return (j, et) let msg t = do setMessage t redirect $ TicketR shr prj num case (ticketDone ticket, ticketAssignee ticket) of (True, _) -> msg "The ticket is closed. Can’t assign closed tickets." (False, Just _) -> msg "The ticket is already assigned to someone." (False, Nothing) -> do ((_result, widget), enctype) <- runFormPost $ assignTicketForm vpid jid defaultLayout $(widgetFile "ticket/assign") postTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketAssignR shr prj num = do vpid <- requireAuthId (jid, Entity tid ticket) <- runDB $ do Entity s _ <- getBy404 $ UniqueSharer shr Entity j _ <- getBy404 $ UniqueProject prj s et <- getBy404 $ UniqueTicket j num return (j, et) let msg t = do setMessage t redirect $ TicketR shr prj num case (ticketDone ticket, ticketAssignee ticket) of (True, _) -> msg "The ticket is closed. Can’t assign closed tickets." (False, Just _) -> msg "The ticket is already assigned to someone." (False, Nothing) -> do ((result, widget), enctype) <- runFormPost $ assignTicketForm vpid jid case result of FormSuccess pid -> do sharer <- runDB $ do update tid [TicketAssignee =. Just pid] person <- getJust pid getJust $ personIdent person let si = sharerIdent sharer msg $ toHtml $ "The ticket is now assigned to " <> shr2text si <> "." FormMissing -> do setMessage "Field(s) missing." defaultLayout $(widgetFile "ticket/assign") FormFailure _l -> do setMessage "Ticket assignment failed, see errors below." defaultLayout $(widgetFile "ticket/assign") postTicketUnassignR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketUnassignR shr prj num = do pid <- requireAuthId mmsg <- runDB $ do Entity tid ticket <- do Entity s _ <- getBy404 $ UniqueSharer shr Entity p _ <- getBy404 $ UniqueProject prj s getBy404 $ UniqueTicket p num case ((== pid) <$> ticketAssignee ticket, ticketDone ticket) of (Nothing, _) -> return $ Just "The ticket is already unassigned." (Just True, _) -> return $ Just "The ticket is assigned to you, unclaim instead." (Just False, True) -> do $logWarn "Found a closed claimed ticket, this is invalid" return $ Just "The ticket is closed. Can’t unclaim closed tickets." (Just False, False) -> do update tid [TicketAssignee =. Nothing] return Nothing setMessage $ fromMaybe "The ticket is now unassigned." mmsg redirect $ TicketR shr prj num selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId selectDiscussionId shar proj tnum = do Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum return $ ticketDiscuss ticket getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketDiscussionR shar proj num = getDiscussion (TicketReplyR shar proj num) (TicketTopReplyR shar proj num) (selectDiscussionId shar proj num) postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketDiscussionR shar proj num = postTopReply (TicketDiscussionR shar proj num) (const $ TicketR shar proj num) (selectDiscussionId shar proj num) getTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html getTicketMessageR shar proj tnum cnum = getMessage (TicketReplyR shar proj tnum) (selectDiscussionId shar proj tnum) cnum postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html postTicketMessageR shar proj tnum cnum = postReply (TicketReplyR shar proj tnum) (TicketMessageR shar proj tnum) (const $ TicketR shar proj tnum) (selectDiscussionId shar proj tnum) cnum getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketTopReplyR shar proj num = getTopReply $ TicketDiscussionR shar proj num getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html getTicketReplyR shar proj tnum cnum = getReply (TicketReplyR shar proj tnum) (TicketMessageR shar proj tnum) (selectDiscussionId shar proj tnum) cnum