From 6457bf560749a1e01ebfffd595adcdaa517a4fc3 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 9 Aug 2016 11:36:14 +0000 Subject: [PATCH] Display custom enum fields in ticket page --- config/models | 10 +++- src/Vervis/Form/Ticket.hs | 5 +- src/Vervis/Handler/Ticket.hs | 87 ++++++++++++++++++----------- src/Vervis/Handler/Workflow.hs | 15 ++++- src/Vervis/Model/Workflow.hs | 2 +- templates/ticket/one.hamlet | 16 ++++++ templates/workflow/field/one.hamlet | 8 ++- 7 files changed, 104 insertions(+), 39 deletions(-) diff --git a/config/models b/config/models index 2dd69aa..7551a13 100644 --- a/config/models +++ b/config/models @@ -167,8 +167,9 @@ WorkflowField workflow WorkflowId ident FldIdent name Text - desc Text Maybe + desc Text Maybe type WorkflowFieldType + enm WorkflowFieldEnumId Maybe required Bool -- filter TicketStatusFilterId @@ -196,6 +197,13 @@ TicketParamText UniqueTicketParamText ticket field +TicketParamEnum + ticket TicketId + field WorkflowFieldId + value WorkflowFieldEnumCtorId + + UniqueTicketParamEnum ticket field value + Ticket project ProjectId number Int diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index e76e859..fcaf170 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -78,7 +78,10 @@ newTicketForm wid html = do tfs <- lift $ runDB $ selectList - [WorkflowFieldWorkflow ==. wid, WorkflowFieldType ==. WFTText] + [ WorkflowFieldWorkflow ==. wid + , WorkflowFieldType ==. WFTText + , WorkflowFieldEnm ==. Nothing + ] [] flip renderDivs html $ NewTicket <$> areq textField "Title*" Nothing diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 2329e34..25c88cc 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -63,8 +63,8 @@ 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, delete) -import Database.Persist +import Database.Esqueleto hiding ((=.), (+=.), update, delete) +import Database.Persist hiding ((==.)) import Text.Blaze.Html (Html, toHtml) import Yesod.Auth (requireAuthId, maybeAuthId) import Yesod.Core (defaultLayout) @@ -105,10 +105,10 @@ getTicketsR shar proj = do 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 + sharer ^. SharerIdent ==. val shar &&. + project ^. ProjectSharer ==. sharer ^. SharerId &&. + project ^. ProjectIdent ==. val proj &&. + ticket ^. TicketProject ==. project ^. ProjectId orderBy [asc $ ticket ^. TicketNumber] return ( ticket ^. TicketNumber @@ -187,7 +187,8 @@ getTicketNewR shar proj = do getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketR shar proj num = do mpid <- maybeAuthId - (wshr, wfl, author, massignee, closer, ticket, tparams, deps, rdeps) <- + ( wshr, wfl, + author, massignee, closer, ticket, tparams, eparams, deps, rdeps) <- runDB $ do (jid, wshr, wid, wfl) <- do Entity s sharer <- getBy404 $ UniqueSharer shar @@ -217,31 +218,52 @@ getTicketR shar proj num = do person <- get404 $ ticketCloser ticket get404 $ personIdent person else return author - tparams <- select $ from $ \ (f `LeftOuterJoin` p) -> do + tparams <- select $ from $ \ (p `RightOuterJoin` f) -> do on $ - just (f ^. WorkflowFieldId) E.==. p ?. TicketParamTextField + p ?. TicketParamTextField ==. just (f ^. WorkflowFieldId) &&. - p ?. TicketParamTextTicket E.==. just (val tid) + p ?. TicketParamTextTicket ==. just (val tid) where_ $ - f ^. WorkflowFieldWorkflow E.==. val wid &&. - f ^. WorkflowFieldType E.==. val WFTText + f ^. WorkflowFieldWorkflow ==. val wid &&. + f ^. WorkflowFieldType ==. val WFTText &&. + isNothing (f ^. WorkflowFieldEnm) return ( f ^. WorkflowFieldIdent , f ^. WorkflowFieldName , f ^. WorkflowFieldRequired , 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 - on $ dep ^. TicketDependencyChild E.==. t ^. TicketId - where_ $ dep ^. TicketDependencyParent E.==. val tid + on $ dep ^. TicketDependencyChild ==. t ^. TicketId + where_ $ dep ^. TicketDependencyParent ==. val tid return t rdeps <- select $ from $ \ (dep `InnerJoin` t) -> do - on $ dep ^. TicketDependencyParent E.==. t ^. TicketId - where_ $ dep ^. TicketDependencyChild E.==. val tid + on $ dep ^. TicketDependencyParent ==. t ^. TicketId + where_ $ dep ^. TicketDependencyChild ==. val tid return t return ( 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 discuss = @@ -249,6 +271,7 @@ getTicketR shar proj num = do (return $ ticketDiscuss ticket) (TicketTopReplyR shar proj num) (TicketReplyR shar proj num) + error' = error :: String -> String defaultLayout $(widgetFile "ticket/one") putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html @@ -467,10 +490,10 @@ 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 + on $ project ^. ProjectSharer ==. sharer ^. SharerId + on $ ticket ^. TicketProject ==. project ^. ProjectId + on $ tcr ^. TicketClaimRequestTicket ==. ticket ^. TicketId + where_ $ tcr ^. TicketClaimRequestPerson ==. val pid orderBy [desc $ tcr ^. TicketClaimRequestCreated] return ( sharer ^. SharerIdent @@ -493,10 +516,10 @@ getClaimRequestsProjectR shr prj = do 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 + on $ person ^. PersonIdent ==. sharer ^. SharerId + on $ tcr ^. TicketClaimRequestPerson ==. person ^. PersonId + on $ tcr ^. TicketClaimRequestTicket ==. ticket ^. TicketId + where_ $ ticket ^. TicketProject ==. val jid orderBy [desc $ tcr ^. TicketClaimRequestCreated] return ( sharer @@ -514,9 +537,9 @@ getClaimRequestsTicketR shr prj num = do 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 + on $ person ^. PersonIdent ==. sharer ^. SharerId + on $ tcr ^. TicketClaimRequestPerson ==. person ^. PersonId + where_ $ tcr ^. TicketClaimRequestTicket ==. val tid orderBy [desc $ tcr ^. TicketClaimRequestCreated] return (sharer, tcr) defaultLayout $(widgetFile "ticket/claim-request/list") @@ -620,10 +643,10 @@ getTicketDeps forward shr prj num = do person `InnerJoin` sharer ) -> do - on $ person ^. PersonIdent E.==. sharer ^. SharerId - on $ ticket ^. TicketCreator E.==. person ^. PersonId - on $ td ^. to' E.==. ticket ^. TicketId - where_ $ td ^. from' E.==. val tid + on $ person ^. PersonIdent ==. sharer ^. SharerId + on $ ticket ^. TicketCreator ==. person ^. PersonId + on $ td ^. to' ==. ticket ^. TicketId + where_ $ td ^. from' ==. val tid orderBy [asc $ ticket ^. TicketNumber] return ( ticket ^. TicketNumber diff --git a/src/Vervis/Handler/Workflow.hs b/src/Vervis/Handler/Workflow.hs index 1b71db6..dba0d19 100644 --- a/src/Vervis/Handler/Workflow.hs +++ b/src/Vervis/Handler/Workflow.hs @@ -56,12 +56,13 @@ import Yesod.Core (defaultLayout) import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) -import Yesod.Persist.Core (runDB, getBy404) +import Yesod.Persist.Core (runDB, get404, getBy404) import Vervis.Form.Workflow import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Model.Workflow import Vervis.Settings import Vervis.Widget.Sharer @@ -149,6 +150,7 @@ postWorkflowFieldsR shr wfl = do , workflowFieldName = nfName nf , workflowFieldDesc = nfDesc nf , workflowFieldType = nfType nf + , workflowFieldEnm = Nothing , workflowFieldRequired = nfReq nf } runDB $ insert_ field @@ -172,11 +174,18 @@ getWorkflowFieldNewR shr wfl = do getWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html getWorkflowFieldR shr wfl fld = do - f <- runDB $ do + (f, e) <- runDB $ do Entity sid _ <- getBy404 $ UniqueSharer shr Entity wid _ <- getBy404 $ UniqueWorkflow sid wfl 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") deleteWorkflowFieldR :: ShrIdent -> WflIdent -> FldIdent -> Handler Html diff --git a/src/Vervis/Model/Workflow.hs b/src/Vervis/Model/Workflow.hs index 7824f3a..c0717cf 100644 --- a/src/Vervis/Model/Workflow.hs +++ b/src/Vervis/Model/Workflow.hs @@ -22,7 +22,7 @@ import Prelude import Database.Persist.TH -data WorkflowFieldType = WFTText +data WorkflowFieldType = WFTText | WFTEnum deriving (Eq, Show, Read, Bounded, Enum) derivePersistField "WorkflowFieldType" diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index f4310b2..741bd77 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -115,6 +115,22 @@ $if not $ ticketDone ticket NO VALUE FOR REQUIRED FIELD $else (none) + $forall (Value fld, Value name, Value req, Value me, Value mc) <- eparams +
  • + + #{name} + : + $case (me, mc) + $of (Just e, Just c) + + #{c} + $of (Nothing, Nothing) + $if req + NO VALUE FOR REQUIRED FIELD + $else + (none) + $of _ + #{error' "Impossible!"}

    Discussion diff --git a/templates/workflow/field/one.hamlet b/templates/workflow/field/one.hamlet index 1bfc7c5..da5e1b4 100644 --- a/templates/workflow/field/one.hamlet +++ b/templates/workflow/field/one.hamlet @@ -23,6 +23,12 @@ $# .
  • Description: #{fromMaybe "(none)" $ workflowFieldDesc f}
  • - Type: #{show $ workflowFieldType f} + Type: + $case e + $of Left typ + #{show typ} + $of Right enum + + #{workflowFieldEnumName enum}
  • Required: #{workflowFieldRequired f}