forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Display custom enum fields in ticket page

Browse source
This commit is contained in:
fr33domlover 2016-08-09 11:36:14 +00:00
parent 1d0d4f697d
commit 6457bf5607
7 changed files with 104 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
config/models
View file

@ -167,8 +167,9 @@ WorkflowField
workflow WorkflowId workflow WorkflowId
ident FldIdent ident FldIdent
name Text name Text
desc Text Maybe desc Text Maybe
type WorkflowFieldType type WorkflowFieldType
enm WorkflowFieldEnumId Maybe
required Bool required Bool
-- filter TicketStatusFilterId -- filter TicketStatusFilterId
@ -196,6 +197,13 @@ TicketParamText
UniqueTicketParamText ticket field UniqueTicketParamText ticket field
TicketParamEnum
ticket TicketId
field WorkflowFieldId
value WorkflowFieldEnumCtorId
UniqueTicketParamEnum ticket field value
Ticket Ticket
project ProjectId project ProjectId
number Int number Int

5
src/Vervis/Form/Ticket.hs
View file

@ -78,7 +78,10 @@ newTicketForm wid html = do
tfs <- tfs <-
lift $ runDB $ lift $ runDB $
selectList selectList
[WorkflowFieldWorkflow ==. wid, WorkflowFieldType ==. WFTText] [ WorkflowFieldWorkflow ==. wid
, WorkflowFieldType ==. WFTText
, WorkflowFieldEnm ==. Nothing
]
[] []
flip renderDivs html $ NewTicket flip renderDivs html $ NewTicket
<$> areq textField "Title*" Nothing <$> areq textField "Title*" Nothing

87
src/Vervis/Handler/Ticket.hs
View file

@ -63,8 +63,8 @@ import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Traversable (for) import Data.Traversable (for)
import Database.Esqueleto hiding ((==.), (=.), (+=.), update, delete) import Database.Esqueleto hiding ((=.), (+=.), update, delete)
import Database.Persist import Database.Persist hiding ((==.))
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
import Yesod.Auth (requireAuthId, maybeAuthId) import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Core (defaultLayout) import Yesod.Core (defaultLayout)
@ -105,10 +105,10 @@ getTicketsR shar proj = do
error $ "Ticket filter form failed: " ++ show l error $ "Ticket filter form failed: " ++ show l
rows <- runDB $ select $ from $ \ (sharer, project, ticket) -> do rows <- runDB $ select $ from $ \ (sharer, project, ticket) -> do
where_ $ filterTickets tf ticket $ where_ $ filterTickets tf ticket $
sharer ^. SharerIdent E.==. val shar &&. sharer ^. SharerIdent ==. val shar &&.
project ^. ProjectSharer E.==. sharer ^. SharerId &&. project ^. ProjectSharer ==. sharer ^. SharerId &&.
project ^. ProjectIdent E.==. val proj &&. project ^. ProjectIdent ==. val proj &&.
ticket ^. TicketProject E.==. project ^. ProjectId ticket ^. TicketProject ==. project ^. ProjectId
orderBy [asc $ ticket ^. TicketNumber] orderBy [asc $ ticket ^. TicketNumber]
return return
( ticket ^. TicketNumber ( ticket ^. TicketNumber
@ -187,7 +187,8 @@ getTicketNewR shar proj = do
getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketR shar proj num = do getTicketR shar proj num = do
mpid <- maybeAuthId mpid <- maybeAuthId
(wshr, wfl, author, massignee, closer, ticket, tparams, deps, rdeps) <- ( wshr, wfl,
author, massignee, closer, ticket, tparams, eparams, deps, rdeps) <-
runDB $ do runDB $ do
(jid, wshr, wid, wfl) <- do (jid, wshr, wid, wfl) <- do
Entity s sharer <- getBy404 $ UniqueSharer shar Entity s sharer <- getBy404 $ UniqueSharer shar
@ -217,31 +218,52 @@ getTicketR shar proj num = do
person <- get404 $ ticketCloser ticket person <- get404 $ ticketCloser ticket
get404 $ personIdent person get404 $ personIdent person
else return author else return author
tparams <- select $ from $ \ (f `LeftOuterJoin` p) -> do tparams <- select $ from $ \ (p `RightOuterJoin` f) -> do
on $ on $
just (f ^. WorkflowFieldId) E.==. p ?. TicketParamTextField p ?. TicketParamTextField ==. just (f ^. WorkflowFieldId)
&&. &&.
p ?. TicketParamTextTicket E.==. just (val tid) p ?. TicketParamTextTicket ==. just (val tid)
where_ $ where_ $
f ^. WorkflowFieldWorkflow E.==. val wid &&. f ^. WorkflowFieldWorkflow ==. val wid &&.
f ^. WorkflowFieldType E.==. val WFTText f ^. WorkflowFieldType ==. val WFTText &&.
isNothing (f ^. WorkflowFieldEnm)
return return
( f ^. WorkflowFieldIdent ( f ^. WorkflowFieldIdent
, f ^. WorkflowFieldName , f ^. WorkflowFieldName
, f ^. WorkflowFieldRequired , f ^. WorkflowFieldRequired
, p ?. TicketParamTextValue , p ?. TicketParamTextValue
) )
eparams <- select $ from $ \ (p `InnerJoin` c `InnerJoin` e `RightOuterJoin` f) -> do
on $
f ^. WorkflowFieldWorkflow ==. val wid &&.
f ^. WorkflowFieldType ==. val WFTEnum &&.
f ^. WorkflowFieldEnm ==. e ?. WorkflowFieldEnumId &&.
p ?. TicketParamEnumField ==. just (f ^. WorkflowFieldId)
on $
e ?. WorkflowFieldEnumWorkflow ==. just (val wid) &&.
c ?. WorkflowFieldEnumCtorEnum ==. e ?. WorkflowFieldEnumId
on $
p ?. TicketParamEnumTicket ==. just (val tid) &&.
p ?. TicketParamEnumValue ==. c ?. WorkflowFieldEnumCtorId
return
( f ^. WorkflowFieldIdent
, f ^. WorkflowFieldName
, f ^. WorkflowFieldRequired
, e ?. WorkflowFieldEnumIdent
, c ?. WorkflowFieldEnumCtorName
)
deps <- select $ from $ \ (dep `InnerJoin` t) -> do deps <- select $ from $ \ (dep `InnerJoin` t) -> do
on $ dep ^. TicketDependencyChild E.==. t ^. TicketId on $ dep ^. TicketDependencyChild ==. t ^. TicketId
where_ $ dep ^. TicketDependencyParent E.==. val tid where_ $ dep ^. TicketDependencyParent ==. val tid
return t return t
rdeps <- select $ from $ \ (dep `InnerJoin` t) -> do rdeps <- select $ from $ \ (dep `InnerJoin` t) -> do
on $ dep ^. TicketDependencyParent E.==. t ^. TicketId on $ dep ^. TicketDependencyParent ==. t ^. TicketId
where_ $ dep ^. TicketDependencyChild E.==. val tid where_ $ dep ^. TicketDependencyChild ==. val tid
return t return t
return return
( wshr, wfl ( wshr, wfl
, author, massignee, closer, ticket, tparams, deps, rdeps , author, massignee, closer, ticket, tparams, eparams
, deps, rdeps
) )
let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket
discuss = discuss =
@ -249,6 +271,7 @@ getTicketR shar proj num = do
(return $ ticketDiscuss ticket) (return $ ticketDiscuss ticket)
(TicketTopReplyR shar proj num) (TicketTopReplyR shar proj num)
(TicketReplyR shar proj num) (TicketReplyR shar proj num)
error' = error :: String -> String
defaultLayout $(widgetFile "ticket/one") defaultLayout $(widgetFile "ticket/one")
putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
@ -467,10 +490,10 @@ getClaimRequestsPersonR = do
pid <- requireAuthId pid <- requireAuthId
rqs <- runDB $ select $ from $ rqs <- runDB $ select $ from $
\ (tcr `InnerJoin` ticket `InnerJoin` project `InnerJoin` sharer) -> do \ (tcr `InnerJoin` ticket `InnerJoin` project `InnerJoin` sharer) -> do
on $ project ^. ProjectSharer E.==. sharer ^. SharerId on $ project ^. ProjectSharer ==. sharer ^. SharerId
on $ ticket ^. TicketProject E.==. project ^. ProjectId on $ ticket ^. TicketProject ==. project ^. ProjectId
on $ tcr ^. TicketClaimRequestTicket E.==. ticket ^. TicketId on $ tcr ^. TicketClaimRequestTicket ==. ticket ^. TicketId
where_ $ tcr ^. TicketClaimRequestPerson E.==. val pid where_ $ tcr ^. TicketClaimRequestPerson ==. val pid
orderBy [desc $ tcr ^. TicketClaimRequestCreated] orderBy [desc $ tcr ^. TicketClaimRequestCreated]
return return
( sharer ^. SharerIdent ( sharer ^. SharerIdent
@ -493,10 +516,10 @@ getClaimRequestsProjectR shr prj = do
person `InnerJoin` person `InnerJoin`
sharer sharer
) -> do ) -> do
on $ person ^. PersonIdent E.==. sharer ^. SharerId on $ person ^. PersonIdent ==. sharer ^. SharerId
on $ tcr ^. TicketClaimRequestPerson E.==. person ^. PersonId on $ tcr ^. TicketClaimRequestPerson ==. person ^. PersonId
on $ tcr ^. TicketClaimRequestTicket E.==. ticket ^. TicketId on $ tcr ^. TicketClaimRequestTicket ==. ticket ^. TicketId
where_ $ ticket ^. TicketProject E.==. val jid where_ $ ticket ^. TicketProject ==. val jid
orderBy [desc $ tcr ^. TicketClaimRequestCreated] orderBy [desc $ tcr ^. TicketClaimRequestCreated]
return return
( sharer ( sharer
@ -514,9 +537,9 @@ getClaimRequestsTicketR shr prj num = do
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity tid _ <- getBy404 $ UniqueTicket jid num Entity tid _ <- getBy404 $ UniqueTicket jid num
select $ from $ \ (tcr `InnerJoin` person `InnerJoin` sharer) -> do select $ from $ \ (tcr `InnerJoin` person `InnerJoin` sharer) -> do
on $ person ^. PersonIdent E.==. sharer ^. SharerId on $ person ^. PersonIdent ==. sharer ^. SharerId
on $ tcr ^. TicketClaimRequestPerson E.==. person ^. PersonId on $ tcr ^. TicketClaimRequestPerson ==. person ^. PersonId
where_ $ tcr ^. TicketClaimRequestTicket E.==. val tid where_ $ tcr ^. TicketClaimRequestTicket ==. val tid
orderBy [desc $ tcr ^. TicketClaimRequestCreated] orderBy [desc $ tcr ^. TicketClaimRequestCreated]
return (sharer, tcr) return (sharer, tcr)
defaultLayout $(widgetFile "ticket/claim-request/list") defaultLayout $(widgetFile "ticket/claim-request/list")
@ -620,10 +643,10 @@ getTicketDeps forward shr prj num = do
person `InnerJoin` person `InnerJoin`
sharer sharer
) -> do ) -> do
on $ person ^. PersonIdent E.==. sharer ^. SharerId on $ person ^. PersonIdent ==. sharer ^. SharerId
on $ ticket ^. TicketCreator E.==. person ^. PersonId on $ ticket ^. TicketCreator ==. person ^. PersonId
on $ td ^. to' E.==. ticket ^. TicketId on $ td ^. to' ==. ticket ^. TicketId
where_ $ td ^. from' E.==. val tid where_ $ td ^. from' ==. val tid
orderBy [asc $ ticket ^. TicketNumber] orderBy [asc $ ticket ^. TicketNumber]
return return
( ticket ^. TicketNumber ( ticket ^. TicketNumber

15
src/Vervis/Handler/Workflow.hs
View file

@ -56,12 +56,13 @@ import Yesod.Core (defaultLayout)
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
import Yesod.Form.Functions (runFormPost) import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..)) import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404) import Yesod.Persist.Core (runDB, get404, getBy404)
import Vervis.Form.Workflow import Vervis.Form.Workflow
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Workflow
import Vervis.Settings import Vervis.Settings
import Vervis.Widget.Sharer import Vervis.Widget.Sharer
@ -149,6 +150,7 @@ postWorkflowFieldsR shr wfl = do
, workflowFieldName = nfName nf , workflowFieldName = nfName nf
, workflowFieldDesc = nfDesc nf , workflowFieldDesc = nfDesc nf
, workflowFieldType = nfType nf , workflowFieldType = nfType nf
, workflowFieldEnm = Nothing
, workflowFieldRequired = nfReq nf , workflowFieldRequired = nfReq nf
} }
runDB $ insert_ field runDB $ insert_ field
@ -172,11 +174,18 @@ getWorkflowFieldNewR shr wfl = do
getWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html getWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html
getWorkflowFieldR shr wfl fld = do getWorkflowFieldR shr wfl fld = do
f <- runDB $ do (f, e) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl
Entity _ f <- getBy404 $ UniqueWorkflowField wid fld Entity _ f <- getBy404 $ UniqueWorkflowField wid fld
return f let typ = workflowFieldType f
menum = workflowFieldEnm f
e <- case (typ, menum) of
(WFTEnum, Just eid) -> Right <$> get404 eid
(WFTEnum, Nothing) -> error "enum field doesn't specify enum"
(_, Just _) -> error "non-enum field specifies enum"
(_, Nothing) -> return $ Left typ
return (f, e)
defaultLayout $(widgetFile "workflow/field/one") defaultLayout $(widgetFile "workflow/field/one")
deleteWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html deleteWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html

2
src/Vervis/Model/Workflow.hs
View file

@ -22,7 +22,7 @@ import Prelude
import Database.Persist.TH import Database.Persist.TH
data WorkflowFieldType = WFTText data WorkflowFieldType = WFTText | WFTEnum
deriving (Eq, Show, Read, Bounded, Enum) deriving (Eq, Show, Read, Bounded, Enum)
derivePersistField "WorkflowFieldType" derivePersistField "WorkflowFieldType"

16
templates/ticket/one.hamlet
View file

@ -115,6 +115,22 @@ $if not $ ticketDone ticket
NO VALUE FOR REQUIRED FIELD NO VALUE FOR REQUIRED FIELD
$else $else
(none) (none)
$forall (Value fld, Value name, Value req, Value me, Value mc) <- eparams
<li>
<a href=@{WorkflowFieldR wshr wfl fld}>
#{name}
:
$case (me, mc)
$of (Just e, Just c)
<a href=@{WorkflowEnumCtorsR wshr wfl e}>
#{c}
$of (Nothing, Nothing)
$if req
NO VALUE FOR REQUIRED FIELD
$else
(none)
$of _
#{error' "Impossible!"}
<h3>Discussion <h3>Discussion

8
templates/workflow/field/one.hamlet
View file

@ -23,6 +23,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<li> <li>
Description: #{fromMaybe "(none)" $ workflowFieldDesc f} Description: #{fromMaybe "(none)" $ workflowFieldDesc f}
<li> <li>
Type: #{show $ workflowFieldType f} Type:
$case e
$of Left typ
#{show typ}
$of Right enum
<a href=@{WorkflowEnumR shr wfl $ workflowFieldEnumIdent enum}>
#{workflowFieldEnumName enum}
<li> <li>
Required: #{workflowFieldRequired f} Required: #{workflowFieldRequired f}