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
    , postTicketCloseR
    , postTicketOpenR
    , postTicketClaimR
    , postTicketUnclaimR
    , getTicketAssignR
    , postTicketAssignR
    , postTicketUnassignR
    , getClaimRequestsPersonR
    , getClaimRequestsProjectR
    , getClaimRequestsTicketR
    , postClaimRequestsTicketR
    , getClaimRequestNewR
    , getTicketDiscussionR
    , postTicketDiscussionR
    , getTicketMessageR
    , postTicketMessageR
    , getTicketTopReplyR
    , getTicketReplyR
    , getTicketDepsR
    )
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

-- | The logged-in user gets a list of the ticket claim requests they have
-- opened, in any project.
getClaimRequestsPersonR :: Handler Html
getClaimRequestsPersonR = do
    pid <- requireAuthId
    rqs <- runDB $ select $ from $
        \ (tcr `InnerJoin` ticket `InnerJoin` project `InnerJoin` sharer) -> do
            on $ project ^. ProjectSharer E.==. sharer ^. SharerId
            on $ ticket ^. TicketProject E.==. project ^. ProjectId
            on $ tcr ^. TicketClaimRequestTicket E.==. ticket ^. TicketId
            where_ $ tcr ^. TicketClaimRequestPerson E.==. val pid
            orderBy [desc $ tcr ^. TicketClaimRequestCreated]
            return
                ( sharer ^. SharerIdent
                , project ^. ProjectIdent
                , ticket ^. TicketNumber
                , ticket ^. TicketTitle
                , tcr ^. TicketClaimRequestCreated
                )
    defaultLayout $(widgetFile "person/claim-requests")

-- | Get a list of ticket claim requests for a given project.
getClaimRequestsProjectR :: ShrIdent -> PrjIdent -> Handler Html
getClaimRequestsProjectR shr prj = do
    rqs <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        select $ from $
            \ ( tcr    `InnerJoin`
                ticket `InnerJoin`
                person `InnerJoin`
                sharer
              ) -> do
                on $ person ^. PersonIdent E.==. sharer ^. SharerId
                on $ tcr ^. TicketClaimRequestPerson E.==. person ^. PersonId
                on $ tcr ^. TicketClaimRequestTicket E.==. ticket ^. TicketId
                where_ $ ticket ^. TicketProject E.==. val jid
                orderBy [desc $ tcr ^. TicketClaimRequestCreated]
                return
                    ( sharer
                    , ticket ^. TicketNumber
                    , ticket ^. TicketTitle
                    , tcr ^. TicketClaimRequestCreated
                    )
    defaultLayout $(widgetFile "project/claim-request/list")

-- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getClaimRequestsTicketR shr prj num = do
    rqs <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        select $ from $ \ (tcr `InnerJoin` person `InnerJoin` sharer) -> do
                on $ person ^. PersonIdent E.==. sharer ^. SharerId
                on $ tcr ^. TicketClaimRequestPerson E.==. person ^. PersonId
                where_ $ tcr ^. TicketClaimRequestTicket E.==. val tid
                orderBy [desc $ tcr ^. TicketClaimRequestCreated]
                return (sharer, tcr)
    defaultLayout $(widgetFile "ticket/claim-request/list")

getClaimRequestNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getClaimRequestNewR shr prj num = do
    ((_result, widget), etype) <- runFormPost claimRequestForm
    defaultLayout $(widgetFile "ticket/claim-request/new")

postClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postClaimRequestsTicketR shr prj num = do
    ((result, widget), etype) <- runFormPost claimRequestForm
    case result of
        FormSuccess msg -> do
            now <- liftIO getCurrentTime
            pid <- requireAuthId
            runDB $ do
                tid <- do
                    Entity s _ <- getBy404 $ UniqueSharer shr
                    Entity j _ <- getBy404 $ UniqueProject prj s
                    Entity t _ <- getBy404 $ UniqueTicket j num
                    return t
                let cr = TicketClaimRequest
                        { ticketClaimRequestPerson  = pid
                        , ticketClaimRequestTicket  = tid
                        , ticketClaimRequestMessage = msg
                        , ticketClaimRequestCreated = now
                        }
                insert_ cr
            setMessage "Ticket claim request opened."
            redirect $ TicketR shr prj num
        FormMissing -> do
            setMessage "Field(s) missing."
            defaultLayout $(widgetFile "ticket/claim-request/new")
        FormFailure _l -> do
            setMessage "Submission failed, see errors below."
            defaultLayout $(widgetFile "ticket/claim-request/new")

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

getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDepsR shr prj num = do
    rows <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        select $ from $
            \ ( td     `InnerJoin`
                ticket `InnerJoin`
                person `InnerJoin`
                sharer
              ) -> do
                on $ person ^. PersonIdent E.==. sharer ^. SharerId
                on $ ticket  ^. TicketCreator E.==. person ^. PersonId
                on $ td ^. TicketDependencyChild E.==. ticket ^. TicketId
                where_ $ td ^. TicketDependencyParent E.==. val tid
                orderBy [asc $ ticket ^. TicketNumber]
                return
                    ( ticket ^. TicketNumber
                    , sharer
                    , ticket ^. TicketTitle
                    , ticket ^. TicketDone
                    )
    defaultLayout $(widgetFile "ticket/dep/list")