mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-10 01:06:46 +09:00
c6c41b485c
I used this chance to make some name changes, add some utils, tweak some imports, remove more `setTitle`s and so on. I also made person, repo, key and project creation forms verify CI-uniqueness.
250 lines
9.3 KiB
Haskell
250 lines
9.3 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ 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
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.Handler.Ticket
|
|
( getTicketsR
|
|
, postTicketsR
|
|
, getTicketNewR
|
|
, getTicketR
|
|
, putTicketR
|
|
, deleteTicketR
|
|
, postTicketR
|
|
, getTicketEditR
|
|
, getTicketDiscussionR
|
|
, postTicketDiscussionR
|
|
, getTicketMessageR
|
|
, postTicketMessageR
|
|
, getTicketTopReplyR
|
|
, getTicketReplyR
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.Default.Class (def)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import Data.Time.Calendar (Day (..))
|
|
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
|
import Data.Time.Format (formatTime, defaultTimeLocale)
|
|
import Database.Esqueleto hiding ((==.), (+=.), update)
|
|
import Database.Persist
|
|
import Text.Blaze.Html (Html, toHtml)
|
|
import Yesod.Auth (requireAuthId)
|
|
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.Widget.Discussion (discussionW)
|
|
import Vervis.Widget.Person (sharerLinkW)
|
|
|
|
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
|
|
, 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
|
|
(author, closer, ticket) <- runDB $ do
|
|
Entity sid _sharer <- getBy404 $ UniqueSharer shar
|
|
Entity pid _project <- getBy404 $ UniqueProject proj sid
|
|
Entity _tid ticket <- getBy404 $ UniqueTicket pid num
|
|
person <- get404 $ ticketCreator ticket
|
|
author <- get404 $ personIdent person
|
|
closer <-
|
|
if ticketDone ticket
|
|
then do
|
|
person' <- get404 $ ticketCloser ticket
|
|
get404 $ personIdent person'
|
|
else return author
|
|
return (author, 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
|
|
user <- requireAuthId
|
|
((result, widget), enctype) <- runFormPost $ editTicketForm ticket user
|
|
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
|
|
user <- requireAuthId
|
|
((_result, widget), enctype) <- runFormPost $ editTicketForm ticket user
|
|
defaultLayout $(widgetFile "ticket/edit")
|
|
|
|
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
|