Implement ticket class params

config/models

@@ -335,6 +335,12 @@ TicketParamEnum
 
     UniqueTicketParamEnum ticket field value
 
+TicketParamClass
+    ticket TicketId
+    field  WorkflowFieldId
+
+    UniqueTicketParamClass ticket field
+
 Ticket
     project     ProjectId
     number      Int

migrations/2020_01_05.model

@@ -0,0 +1,5 @@
+TicketParamClass
+    ticket TicketId
+    field  WorkflowFieldId
+
+    UniqueTicketParamClass ticket field

src/Vervis/Form/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -27,7 +27,8 @@ where
 import Control.Applicative (liftA2, liftA3)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
-import Data.Maybe (catMaybes, mapMaybe)
+import Data.Bool
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Calendar (Day (..))
 import Data.Time.Clock (getCurrentTime, UTCTime (..))
@@ -53,6 +54,7 @@ data NewTicket = NewTicket
     , ntDesc    :: Text
     , ntTParams :: [(WorkflowFieldId, Text)]
     , ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
+    , ntCParams :: [WorkflowFieldId]
     }
 
 fieldSettings :: Text -> Bool -> FieldSettings App
@@ -92,9 +94,18 @@ efield (Entity fid f) =
                     then Just <$> areq sel sets Nothing
                     else aopt sel sets Nothing
 
+cfield :: Entity WorkflowField -> AForm Handler (Maybe WorkflowFieldId)
+cfield (Entity fid f) =
+    let sets = fieldSettings (workflowFieldName f) (workflowFieldRequired f)
+        mkval False = Nothing
+        mkval True  = Just fid
+    in  if workflowFieldRequired f
+            then mkval <$> areq checkBoxField sets Nothing
+            else mkval . fromMaybe False <$> aopt checkBoxField sets Nothing
+
 newTicketForm :: WorkflowId -> Form NewTicket
 newTicketForm wid html = do
-    (tfs, efs) <- lift $ runDB $ do
+    (tfs, efs, cfs) <- lift $ runDB $ do
         tfs <- selectList
             [ WorkflowFieldWorkflow  ==. wid
             , WorkflowFieldType      ==. WFTText
@@ -108,7 +119,14 @@ newTicketForm wid html = do
             , WorkflowFieldFilterNew ==. True
             ]
             []
-        return (tfs, efs)
+        cfs <- selectList
+            [ WorkflowFieldWorkflow  ==. wid
+            , WorkflowFieldType      ==. WFTClass
+            , WorkflowFieldEnm       ==. Nothing
+            , WorkflowFieldFilterNew ==. True
+            ]
+            []
+        return (tfs, efs, cfs)
     flip renderDivs html $ NewTicket
         <$> (sanitizeBalance <$> areq textField "Title*" Nothing)
         <*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
@@ -116,6 +134,7 @@ newTicketForm wid html = do
             )
         <*> (catMaybes <$> traverse tfield tfs)
         <*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
+        <*> (catMaybes <$> traverse cfield cfs)
 
 editTicketContentAForm :: Ticket -> AForm Handler Ticket
 editTicketContentAForm ticket = Ticket
@@ -172,6 +191,13 @@ eEditField (TicketEnumParam (WorkflowFieldSummary fid _ name req _ _) e mv) =
             then Just <$> areq sel sets (tepvVal <$> mv)
             else aopt sel sets (Just . tepvVal <$> mv)
 
+cEditField
+    :: TicketClassParam
+    -> AForm Handler (Maybe TicketParamClassId, Maybe WorkflowFieldId)
+cEditField (TicketClassParam (WorkflowFieldSummary fid _ name req _ _) mv) =
+    let sets = fieldSettings name req
+    in  (mv,) . bool Nothing (Just fid) <$> areq checkBoxField sets (Just $ isJust mv)
+
 editableField :: Ticket -> WorkflowFieldSummary -> Bool
 editableField t f =
     not (wfsConstant f) &&
@@ -194,22 +220,30 @@ editTicketContentForm
             , Maybe (WorkflowFieldId, WorkflowEnumCtorId)
             )
           ]
+        , [ ( Maybe TicketParamClassId
+            , Maybe WorkflowFieldId
+            )
+          ]
         )
 editTicketContentForm tid t wid html = do
-    (tfs, efs) <-
+    (tfs, efs, cfs) <-
         lift $ runDB $
-        liftA2 (,)
+        liftA3 (,,)
             ( filter (editableField t . ttpField) <$>
                 getTicketTextParams tid wid
             )
             ( filter (editableField t . tepField) <$>
                 getTicketEnumParams tid wid
             )
+            ( filter (editableField t . tcpField) <$>
+                getTicketClasses tid wid
+            )
     flip renderDivs html $
-        liftA3 (,,)
+        (,,,)
-            (editTicketContentAForm t)
+            <$> editTicketContentAForm t
-            (traverse tEditField tfs)
+            <*> traverse tEditField tfs
-            (traverse eEditField efs)
+            <*> traverse eEditField efs
+            <*> traverse cEditField cfs
 
 assignTicketAForm :: PersonId -> ProjectId -> AForm Handler PersonId
 assignTicketAForm pid jid =

src/Vervis/Handler/Client.hs

@@ -667,13 +667,13 @@ postTicketsR shr prj = do
         runDB $ sharerIdent <$> getJust (personIdent p)
 
     enum <- runExceptT $ do
-        NewTicket title desc tparams eparams <-
+        NewTicket title desc tparams eparams cparams <-
             case result of
                 FormMissing -> throwE "Field(s) missing."
                 FormFailure _l ->
                     throwE "Ticket submission failed, see errors below."
                 FormSuccess nt -> return nt
-        unless (null tparams && null eparams) $
+        unless (null tparams && null eparams && null cparams) $
             throwE "Custom param support currently disabled"
             {-
             let mktparam (fid, v) = TicketParamText

src/Vervis/Handler/Ticket.hs

@@ -166,7 +166,8 @@ getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
 getTicketR shar proj num = do
     mpid <- maybeAuthId
     ( wshr, wfl,
-      author, massignee, mcloser, ticket, tparams, eparams, deps, rdeps) <-
+      author, massignee, mcloser, ticket, tparams, eparams, cparams,
+      deps, rdeps) <-
         runDB $ do
             (jid, wshr, wid, wfl) <- do
                 Entity s sharer <- getBy404 $ UniqueSharer shar
@@ -217,6 +218,7 @@ getTicketR shar proj num = do
                             Nothing -> return Nothing
             tparams <- getTicketTextParams tid wid
             eparams <- getTicketEnumParams tid wid
+            cparams <- getTicketClasses tid wid
             deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
                 E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
                 E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
@@ -227,7 +229,7 @@ getTicketR shar proj num = do
                 return t
             return
                 ( wshr, wfl
-                , author, massignee, mcloser, ticket, tparams, eparams
+                , author, massignee, mcloser, ticket, tparams, eparams, cparams
                 , deps, rdeps
                 )
     encodeHid <- getEncodeKeyHashid
@@ -310,7 +312,7 @@ putTicketR shar proj num = do
     ((result, widget), enctype) <-
         runFormPost $ editTicketContentForm tid ticket wid
     case result of
-        FormSuccess (ticket', tparams, eparams) -> do
+        FormSuccess (ticket', tparams, eparams, cparams) -> do
             newDescHtml <-
                 case renderPandocMarkdown $ ticketSource ticket' of
                     Left err -> do
@@ -346,6 +348,13 @@ putTicketR shar proj num = do
                         update aid [TicketParamEnumValue =. v]
                     )
                     eupd
+                let (cdel, cins, _ckeep) = partitionMaybePairs cparams
+                deleteWhere [TicketParamClassId <-. cdel]
+                let mkcparam fid = TicketParamClass
+                        { ticketParamClassTicket = tid
+                        , ticketParamClassField  = fid
+                        }
+                insertMany_ $ map mkcparam cins
             setMessage "Ticket updated."
             redirect $ TicketR shar proj num
         FormMissing -> do

src/Vervis/Migration.hs

@@ -1224,6 +1224,8 @@ changes hLocal ctx =
     , renameUnique "WorkflowEnum" "UniqueWorkflowFieldEnum" "UniqueWorkflowEnum"
       -- 183
     , renameUnique "WorkflowEnumCtor" "UniqueWorkflowFieldEnumCtor" "UniqueWorkflowEnumCtor"
+      -- 184
+    , addEntities model_2020_01_05
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -138,6 +138,7 @@ module Vervis.Migration.Model
     , UnfetchedRemoteActor159
     , RemoteCollection159Generic (..)
     , RemoteCollection159
+    , model_2020_01_05
     )
 where
 
@@ -277,3 +278,6 @@ makeEntitiesMigration "152"
 
 makeEntitiesMigration "159"
     $(modelFile "migrations/2019_11_05_remote_actor_ident.model")
+
+model_2020_01_05 :: [Entity SqlBackend]
+model_2020_01_05 = $(schema "2020_01_05")

src/Vervis/Model/Workflow.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -26,7 +26,7 @@ data WorkflowScope = WSSharer | WSPublic | WSFeatured
 
 derivePersistField "WorkflowScope"
 
-data WorkflowFieldType = WFTText | WFTEnum
+data WorkflowFieldType = WFTText | WFTEnum | WFTClass
     deriving (Eq, Show, Read, Bounded, Enum)
 
 derivePersistField "WorkflowFieldType"

src/Vervis/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -25,6 +25,8 @@ module Vervis.Ticket
     , TicketEnumParamValue (..)
     , TicketEnumParam (..)
     , getTicketEnumParams
+    , TicketClassParam (..)
+    , getTicketClasses
     )
 where
 
@@ -314,3 +316,68 @@ getTicketEnumParams tid wid = fmap (map toEParam) $
             , 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
+            )

templates/ticket/one.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -134,6 +134,15 @@ $if ticketStatus ticket /= TSClosed
           NO VALUE FOR REQUIRED FIELD
         $else
           (none)
+  $forall TicketClassParam field mvalue <- cparams
+    <li .#{relevant $ wfsFilter field}>
+      <a href=@{WorkflowFieldR wshr wfl $ wfsIdent field}>
+        #{wfsName field}
+      :
+      $maybe _tpcid <- mvalue
+        Yes
+      $nothing
+        No
 
 <p>
   ^{buttonW DELETE "Delete this ticket" (TicketR shar proj num)}