vervis/src/Vervis/Ticket.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2020 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.Ticket
    ( getTicketSummaries
    , getTicketDepEdges
    , WorkflowFieldFilter (..)
    , WorkflowFieldSummary (..)
    , TicketTextParamValue (..)
    , TicketTextParam (..)
    , getTicketTextParams
    , WorkflowEnumSummary (..)
    , TicketEnumParamValue (..)
    , TicketEnumParam (..)
    , getTicketEnumParams
    , TicketClassParam (..)
    , getTicketClasses
    , getSharerTicket
    , getSharerTicket404
    , getProjectTicket
    , getProjectTicket404
    )
where

import Control.Arrow ((***))
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Foldable (for_)
import Data.Int
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Traversable
import Database.Esqueleto
import Yesod.Core (notFound)

import Yesod.Hashids

import Data.Either.Local
import Database.Persist.Local

import Vervis.Foundation (AppDB)
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Workflow
import Vervis.Widget.Ticket (TicketSummary (..))

-- | Get summaries of all the tickets in the given project.
getTicketSummaries
    :: Maybe (SqlExpr (Entity Ticket) -> SqlExpr (Value Bool))
    -> Maybe (SqlExpr (Entity Ticket) -> [SqlExpr OrderBy])
    -> Maybe (Int, Int)
    -> ProjectId
    -> AppDB [TicketSummary]
getTicketSummaries mfilt morder offlim jid = do
    tickets <- select $ from $
        \ ( t
            `InnerJoin` lt
            `InnerJoin` tpl
            `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s `LeftOuterJoin` tup)
            `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
            `InnerJoin` d
            `LeftOuterJoin` m
          ) -> do
            on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
            on $ lt ^. LocalTicketDiscuss ==. d ^. DiscussionId
            on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
            on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
            on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
            on $ just (tpl ^. TicketProjectLocalId) ==. tar ?. TicketAuthorRemoteTicket
            on $ tal ?. TicketAuthorLocalId  ==. tup ?. TicketUnderProjectAuthor
            on $ p ?. PersonIdent ==. s ?. SharerId
            on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
            on $ just (lt ^. LocalTicketId) ==. tal ?. TicketAuthorLocalTicket
            on $ t ^. TicketId ==. tpl ^. TicketProjectLocalTicket
            on $ t ^. TicketId ==. lt ^. LocalTicketTicket
            where_ $ tpl ^. TicketProjectLocalProject ==. val jid
            groupBy
                ( t ^. TicketId, lt ^. LocalTicketId
                , tal ?. TicketAuthorLocalId, s ?. SharerId, tup ?. TicketUnderProjectId
                , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
                )
            for_ mfilt $ \ filt -> where_ $ filt t
            for_ morder $ \ order -> orderBy $ order t
            for_ offlim $ \ (off, lim) -> do
                offset $ fromIntegral off
                limit $ fromIntegral lim
            return
                ( t ^. TicketId
                , lt ^. LocalTicketId
                , tal ?. TicketAuthorLocalId
                , s
                , tup ?. TicketUnderProjectId
                , i
                , ro
                , ra
                , t ^. TicketCreated
                , t ^. TicketTitle
                , t ^. TicketStatus
                , count $ m ?. MessageId
                )
    for tickets $
        \ (Value tid, Value ltid, Value mtalid, ms, Value mtupid, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
            labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do
                on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId
                where_ $ tpc ^. TicketParamClassTicket ==. val tid
                return wf
            return TicketSummary
                { tsId        = ltid
                , tsCreatedBy =
                    case (mtalid, ms, mi, mro, mra) of
                        (Just talid, Just s, Nothing, Nothing, Nothing) ->
                            Left
                                ( entityVal s
                                , if isJust mtupid then Nothing else Just talid
                                )
                        (Nothing, Nothing, Just i, Just ro, Just ra) ->
                            Right (entityVal i, entityVal ro, entityVal ra)
                        _ -> error "Ticket author DB invalid state"
                , tsCreatedAt = c
                , tsTitle     = t
                , tsLabels    = map entityVal labels
                , tsStatus    = d
                , tsComments  = r
                }

-- | Get the child-parent ticket number pairs of all the ticket dependencies
-- in the given project, in ascending order by child, and then ascending order
-- by parent.
getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)]
getTicketDepEdges jid =
    fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $
    select $ from $ \ (t1 `InnerJoin` tpl1 `InnerJoin` td `InnerJoin` t2 `InnerJoin` tpl2) -> do
        on $ t2 ^. TicketId ==. tpl2 ^. TicketProjectLocalTicket
        on $ t2 ^. TicketId ==. td ^. TicketDependencyParent
        on $ t1 ^. TicketId ==. td ^. TicketDependencyChild
        on $ t1 ^. TicketId ==. tpl1 ^. TicketProjectLocalTicket
        where_ $
            tpl1 ^. TicketProjectLocalProject ==. val jid &&.
            tpl2 ^. TicketProjectLocalProject ==. val jid
        orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId]
        return (t1 ^. TicketId, t2 ^. TicketId)

data WorkflowFieldFilter = WorkflowFieldFilter
    { wffNew    :: Bool
    , wffTodo   :: Bool
    , wffClosed :: Bool
    }

data WorkflowFieldSummary = WorkflowFieldSummary
    { wfsId       :: WorkflowFieldId
    , wfsIdent    :: FldIdent
    , wfsName     :: Text
    , wfsRequired :: Bool
    , wfsConstant :: Bool
    , wfsFilter   :: WorkflowFieldFilter
    }

data TicketTextParamValue = TicketTextParamValue
    { ttpvId  :: TicketParamTextId
    , ttpvVal :: Text
    }

data TicketTextParam = TicketTextParam
    { ttpField :: WorkflowFieldSummary
    , ttpValue :: Maybe TicketTextParamValue
    }

toTParam
    :: ( Value WorkflowFieldId
       , Value FldIdent
       , Value Text
       , Value Bool
       , Value Bool
       , Value Bool
       , Value Bool
       , Value Bool
       , Value (Maybe TicketParamTextId)
       , Value (Maybe Text)
       )
    -> TicketTextParam
toTParam
    ( Value fid
    , Value fld
    , Value name
    , Value req
    , Value con
    , Value new
    , Value todo
    , Value closed
    , Value mp
    , Value mt
    ) =
        TicketTextParam
            { ttpField = WorkflowFieldSummary
                { wfsId       = fid
                , wfsIdent    = fld
                , wfsName     = name
                , wfsRequired = req
                , wfsConstant = con
                , wfsFilter   = WorkflowFieldFilter
                    { wffNew    = new
                    , wffTodo   = todo
                    , wffClosed = closed
                    }
                }
            , ttpValue =
                case (mp, mt) of
                    (Just p,  Just t)  ->
                        Just TicketTextParamValue
                            { ttpvId  = p
                            , ttpvVal = t
                            }
                    (Nothing, Nothing) -> Nothing
                    _                  -> error "Impossible"
            }

getTicketTextParams :: TicketId -> WorkflowId -> AppDB [TicketTextParam]
getTicketTextParams tid wid = fmap (map toTParam) $
    select $ from $ \ (p `RightOuterJoin` f) -> do
        on $
            p ?. TicketParamTextField  ==. just (f ^. WorkflowFieldId) &&.
            p ?. TicketParamTextTicket ==. just (val tid)
        where_ $
            f ^. WorkflowFieldWorkflow ==. val wid     &&.
            f ^. WorkflowFieldType     ==. val WFTText &&.
            isNothing (f ^. WorkflowFieldEnm)
        return
            ( f ^. WorkflowFieldId
            , f ^. WorkflowFieldIdent
            , f ^. WorkflowFieldName
            , f ^. WorkflowFieldRequired
            , f ^. WorkflowFieldConstant
            , f ^. WorkflowFieldFilterNew
            , f ^. WorkflowFieldFilterTodo
            , f ^. WorkflowFieldFilterClosed
            , p ?. TicketParamTextId
            , p ?. TicketParamTextValue
            )

data WorkflowEnumSummary = WorkflowEnumSummary
    { wesId    :: WorkflowEnumId
    , wesIdent :: EnmIdent
    }

data TicketEnumParamValue = TicketEnumParamValue
    { tepvId   :: TicketParamEnumId
    , tepvVal  :: WorkflowEnumCtorId
    , tepvName :: Text
    }

data TicketEnumParam = TicketEnumParam
    { tepField :: WorkflowFieldSummary
    , tepEnum  :: WorkflowEnumSummary
    , tepValue :: Maybe TicketEnumParamValue
    }

toEParam
    :: ( Value WorkflowFieldId
       , Value FldIdent
       , Value Text
       , Value Bool
       , Value Bool
       , Value Bool
       , Value Bool
       , Value Bool
       , Value WorkflowEnumId
       , Value EnmIdent
       , Value (Maybe TicketParamEnumId)
       , Value (Maybe WorkflowEnumCtorId)
       , Value (Maybe Text)
       )
    -> TicketEnumParam
toEParam
    ( Value fid
    , Value fld
    , Value name
    , Value req
    , Value con
    , Value new
    , Value todo
    , Value closed
    , Value i
    , Value e
    , Value mp
    , Value mc
    , Value mt
    ) =
        TicketEnumParam
            { tepField = WorkflowFieldSummary
                { wfsId       = fid
                , wfsIdent    = fld
                , wfsName     = name
                , wfsRequired = req
                , wfsConstant = con
                , wfsFilter   = WorkflowFieldFilter
                    { wffNew    = new
                    , wffTodo   = todo
                    , wffClosed = closed
                    }
                }
            , tepEnum = WorkflowEnumSummary
                { wesId    = i
                , wesIdent = e
                }
            , tepValue =
                case (mp, mc, mt) of
                    (Just p,  Just c,  Just t)  ->
                        Just TicketEnumParamValue
                            { tepvId   = p
                            , tepvVal  = c
                            , tepvName = t
                            }
                    (Nothing, Nothing, Nothing) -> Nothing
                    _                           -> error "Impossible"
            }

getTicketEnumParams :: TicketId -> WorkflowId -> AppDB [TicketEnumParam]
getTicketEnumParams tid wid = fmap (map toEParam) $
    select $ from $ \ (p `InnerJoin` c `RightOuterJoin` f `InnerJoin` e) -> do
        on $
            e ^. WorkflowEnumWorkflow ==. val wid &&.
            f ^. WorkflowFieldEnm          ==. just (e ^. WorkflowEnumId)
        on $
            f ^. WorkflowFieldWorkflow     ==. val wid                     &&.
            f ^. WorkflowFieldType         ==. val WFTEnum                 &&.
            p ?. TicketParamEnumField      ==. just (f ^. WorkflowFieldId) &&.
            c ?. WorkflowEnumCtorEnum ==. f ^. WorkflowFieldEnm
        on $
            p ?. TicketParamEnumTicket ==. just (val tid) &&.
            p ?. TicketParamEnumValue  ==. c ?. WorkflowEnumCtorId
        return
            ( f ^. WorkflowFieldId
            , f ^. WorkflowFieldIdent
            , f ^. WorkflowFieldName
            , f ^. WorkflowFieldRequired
            , f ^. WorkflowFieldConstant
            , f ^. WorkflowFieldFilterNew
            , f ^. WorkflowFieldFilterTodo
            , f ^. WorkflowFieldFilterClosed
            , e ^. WorkflowEnumId
            , e ^. WorkflowEnumIdent
            , p ?. TicketParamEnumId
            , c ?. WorkflowEnumCtorId
            , c ?. WorkflowEnumCtorName
            )

data TicketClassParam = TicketClassParam
    { tcpField :: WorkflowFieldSummary
    , tcpValue :: Maybe TicketParamClassId
    }

toCParam
    :: ( Value WorkflowFieldId
       , Value FldIdent
       , Value Text
       , Value Bool
       , Value Bool
       , Value Bool
       , Value Bool
       , Value Bool
       , Value (Maybe TicketParamClassId)
       )
    -> TicketClassParam
toCParam
    ( Value fid
    , Value fld
    , Value name
    , Value req
    , Value con
    , Value new
    , Value todo
    , Value closed
    , Value mp
    ) = TicketClassParam
            { tcpField = WorkflowFieldSummary
                { wfsId       = fid
                , wfsIdent    = fld
                , wfsName     = name
                , wfsRequired = req
                , wfsConstant = con
                , wfsFilter   = WorkflowFieldFilter
                    { wffNew    = new
                    , wffTodo   = todo
                    , wffClosed = closed
                    }
                }
            , tcpValue = mp
            }

getTicketClasses :: TicketId -> WorkflowId -> AppDB [TicketClassParam]
getTicketClasses tid wid = fmap (map toCParam) $
    select $ from $ \ (p `RightOuterJoin` f) -> do
        on $
            p ?. TicketParamClassField  ==. just (f ^. WorkflowFieldId) &&.
            p ?. TicketParamClassTicket ==. just (val tid)
        where_ $
            f ^. WorkflowFieldWorkflow ==. val wid      &&.
            f ^. WorkflowFieldType     ==. val WFTClass &&.
            isNothing (f ^. WorkflowFieldEnm)
        return
            ( f ^. WorkflowFieldId
            , f ^. WorkflowFieldIdent
            , f ^. WorkflowFieldName
            , f ^. WorkflowFieldRequired
            , f ^. WorkflowFieldConstant
            , f ^. WorkflowFieldFilterNew
            , f ^. WorkflowFieldFilterTodo
            , f ^. WorkflowFieldFilterClosed
            , p ?. TicketParamClassId
            )

getSharerTicket
    :: ShrIdent
    -> TicketAuthorLocalId
    -> AppDB
        ( Maybe
            ( Entity TicketAuthorLocal
            , Entity LocalTicket
            , Entity Ticket
            , Either (Entity TicketProjectLocal) ()
            )
        )
getSharerTicket shr talid = runMaybeT $ do
    pid <- do
        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
        MaybeT $ getKeyBy $ UniquePersonIdent sid
    tal <- MaybeT $ get talid
    guard $ ticketAuthorLocalAuthor tal == pid
    let ltid = ticketAuthorLocalTicket tal
    lt <- lift $ getJust ltid
    let tid = localTicketTicket lt
    t <- lift $ getJust tid
    project <-
        requireEitherAlt
            (do mtpl <- lift $ getBy $ UniqueTicketProjectLocal tid
                for mtpl $ \ etpl@(Entity tplid tpl) -> do
                    mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tplid
                    mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
                    unless (isJust mtup1 == isJust mtup2) $
                        error "TUP points to unrelated TAL and TPL!"
                    guard $ not $ isJust mtup1
                    return etpl
            )
            (return Nothing
            )
            "Ticket doesn't have project"
            "Ticket has both local and remote project"
    return (Entity talid tal, Entity ltid lt, Entity tid t, project)

getSharerTicket404
    :: ShrIdent
    -> KeyHashid TicketAuthorLocal
    -> AppDB
        ( Entity TicketAuthorLocal
        , Entity LocalTicket
        , Entity Ticket
        , Either (Entity TicketProjectLocal) ()
        )
getSharerTicket404 shr talkhid = do
    talid <- decodeKeyHashid404 talkhid
    mticket <- getSharerTicket shr talid
    case mticket of
        Nothing -> notFound
        Just ticket -> return ticket

getProjectTicket
    :: ShrIdent
    -> PrjIdent
    -> LocalTicketId
    -> AppDB
        ( Maybe
            ( Entity Sharer
            , Entity Project
            , Entity Ticket
            , Entity LocalTicket
            , Entity TicketProjectLocal
            , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
            )
        )
getProjectTicket shr prj ltid = runMaybeT $ do
    es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
    ej@(Entity jid _) <- MaybeT $ getBy $ UniqueProject prj sid
    lt <- MaybeT $ get ltid
    let tid = localTicketTicket lt
    t <- MaybeT $ get tid
    etpl@(Entity tplid tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tid
    guard $ ticketProjectLocalProject tpl == jid
    author <-
        requireEitherAlt
            (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
                for mtal $ \ tal@(Entity talid _) -> do
                    tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tplid
                    tupid2 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectAuthor talid
                    unless (tupid1 == tupid2) $
                        error "TAL and TPL used by different TUPs!"
                    return tal
            )
            (lift $ getBy $ UniqueTicketAuthorRemote tplid)
            "Ticket doesn't have author"
            "Ticket has both local and remote author"
    return (es, ej, Entity tid t, Entity ltid lt, etpl, author)

getProjectTicket404
    :: ShrIdent
    -> PrjIdent
    -> KeyHashid LocalTicket
    -> AppDB
        ( Entity Sharer
        , Entity Project
        , Entity Ticket
        , Entity LocalTicket
        , Entity TicketProjectLocal
        , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
        )
getProjectTicket404 shr prj ltkhid = do
    ltid <- decodeKeyHashid404 ltkhid
    mticket <- getProjectTicket shr prj ltid
    case mticket of
        Nothing -> notFound
        Just ticket -> return ticket