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
    )
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 (setMessage, redirect, lookupPostParam, notFound)
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 (filter, intercalate, pack)
import qualified Database.Esqueleto as E ((==.))

import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model
import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile)

getTicketsR :: Text -> Text -> Handler Html
getTicketsR shar proj = do
    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."
            redirect $ TicketR shar proj (ticketNumber ticket)
        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, 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 $ do
        setTitle $ toHtml $ T.intercalate " :: "
            [shar, proj, "Tickets", T.pack ('#' : show num)]
        $(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 $ do
        setTitle $ toHtml $ T.intercalate " :: "
            [shar, proj, "Tickets", T.pack ('#' : show num), "Edit"]
        $(widgetFile "ticket/edit")