vervis/src/Vervis/Handler/Ticket.hs

{- 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.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 (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.Render (renderSourceT)
import Vervis.Settings (widgetFile)
import Vervis.Widget.Discussion (discussionW)

getTicketsR :: Text -> Text -> Handler Html
getTicketsR shar proj = do
    rows <- runDB $ select $ from $ \ (sharer, project, ticket) -> do
        where_ $
            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 ^. SharerIdent
            , sharer ^. SharerName
            , ticket ^. TicketTitle
            , ticket ^. TicketDone
            )
    defaultLayout $(widgetFile "ticket/list")

postTicketsR :: Text -> Text -> 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 $ UniqueSharerIdent 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 :: Text -> Text -> Handler Html
getTicketNewR shar proj = do
    ((_result, widget), enctype) <- runFormPost newTicketForm
    defaultLayout $(widgetFile "ticket/new")

getTicketR :: Text -> Text -> Int -> Handler Html
getTicketR shar proj num = do
    (author, closer, 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
        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
    defaultLayout $(widgetFile "ticket/one")

putTicketR :: Text -> Text -> Int -> Handler Html
putTicketR shar proj num = do
    Entity tid ticket <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharerIdent 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 :: Text -> Text -> 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 :: Text -> Text -> 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 :: Text -> Text -> Int -> Handler Html
getTicketEditR shar proj num = do
    Entity _tid ticket <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharerIdent 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 :: Text -> Text -> Int -> AppDB DiscussionId
selectDiscussionId shar proj tnum = do
    Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
    Entity pid _project <- getBy404 $ UniqueProject proj sid
    Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum
    return $ ticketDiscuss ticket

getTicketDiscussionR :: Text -> Text -> Int -> Handler Html
getTicketDiscussionR shar proj num =
    getDiscussion
        (TicketReplyR shar proj num)
        (selectDiscussionId shar proj num)

postTicketDiscussionR :: Text -> Text -> Int -> Handler Html
postTicketDiscussionR shar proj num =
    postTopReply
        (TicketDiscussionR shar proj num)
        (const $ TicketR shar proj num)
        (selectDiscussionId shar proj num)

getTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html
getTicketMessageR shar proj tnum cnum =
    getMessage
        (TicketReplyR shar proj tnum)
        (selectDiscussionId shar proj tnum)
        cnum

postTicketMessageR :: Text -> Text -> 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 :: Text -> Text -> Int -> Handler Html
getTicketTopReplyR shar proj num =
    getTopReply $ TicketDiscussionR shar proj num

getTicketReplyR :: Text -> Text -> Int -> Int -> Handler Html
getTicketReplyR shar proj tnum cnum =
    getReply
        (TicketReplyR shar proj tnum)
        (TicketMessageR shar proj tnum)
        (selectDiscussionId shar proj tnum)
        cnum