mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-25 16:47:50 +09:00
116 lines
4.2 KiB
Haskell
116 lines
4.2 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
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
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 (redirectUltDest, setMessage)
|
|
import Yesod.Core.Widget (setTitle)
|
|
import Yesod.Form.Functions (runFormPost)
|
|
import Yesod.Form.Types (FormResult (..))
|
|
import Yesod.Persist.Core (runDB, get404, getBy404)
|
|
|
|
import qualified Data.Text as T (intercalate, pack)
|
|
import qualified Database.Esqueleto as E ((==.))
|
|
|
|
import Vervis.Form.Ticket
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Settings (widgetFile)
|
|
|
|
getTicketsR :: Text -> Text -> Handler Html
|
|
getTicketsR shar proj = do
|
|
--tickets <- runDB $ do
|
|
-- Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
|
-- Entity pid _project <- getBy404 $ UniqueProject proj sid
|
|
-- selectList [TicketProject ==. pid] [Asc TicketNumber]
|
|
rows <- runDB $ select $ from $ \ (ticket, person, sharer) -> do
|
|
where_ $
|
|
ticket ^. TicketCreator E.==. person ^. PersonId &&.
|
|
person ^. PersonIdent E.==. sharer ^. SharerId
|
|
orderBy [asc $ ticket ^. TicketNumber]
|
|
return
|
|
( ticket ^. TicketNumber
|
|
, sharer ^. SharerIdent
|
|
, sharer ^. SharerName
|
|
, ticket ^. TicketTitle
|
|
, ticket ^. TicketDone
|
|
)
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.intercalate " :: " [shar, proj, "Tickes"]
|
|
$(widgetFile "ticket/list")
|
|
|
|
postTicketsR :: Text -> Text -> Handler Html
|
|
postTicketsR shar proj = do
|
|
Entity pid project <- runDB $ do
|
|
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
|
getBy404 $ UniqueProject proj sid
|
|
let next = projectNextTicket project
|
|
author <- requireAuthId
|
|
((result, widget), enctype) <- runFormPost $ newTicketForm pid next author
|
|
case result of
|
|
FormSuccess ticket -> do
|
|
runDB $ do
|
|
update pid [ProjectNextTicket +=. 1]
|
|
insert_ ticket
|
|
setMessage "Ticket created."
|
|
redirectUltDest HomeR
|
|
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 :: Text -> Text -> Handler Html
|
|
getTicketNewR shar proj = do
|
|
Entity pid project <- runDB $ do
|
|
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
|
getBy404 $ UniqueProject proj sid
|
|
let next = projectNextTicket project
|
|
author <- requireAuthId
|
|
((_result, widget), enctype) <- runFormPost $ newTicketForm pid next author
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.intercalate " :: " [shar, proj, "New ticket"]
|
|
$(widgetFile "ticket/new")
|
|
|
|
getTicketR :: Text -> Text -> Int -> Handler Html
|
|
getTicketR shar proj num = do
|
|
(author, ticket) <- runDB $ do
|
|
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
|
Entity pid _project <- getBy404 $ UniqueProject proj sid
|
|
Entity _tid ticket <- getBy404 $ UniqueTicket pid num
|
|
person <- get404 $ ticketCreator ticket
|
|
author <- get404 $ personIdent person
|
|
return (author, ticket)
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.intercalate " :: "
|
|
[shar, proj, "Tickets", T.pack ('#' : show num)]
|
|
$(widgetFile "ticket/one")
|