Ticket content edit form lets you edit custom ticket params

src/Vervis/Form/Ticket.hs

@@ -26,6 +26,7 @@ where
 
 import Prelude
 
+import Control.Applicative (liftA2, liftA3)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Data.Maybe (catMaybes, mapMaybe)
@@ -42,16 +43,11 @@ import Vervis.Field.Ticket
 import Vervis.Foundation (App, Form, Handler)
 import Vervis.Model
 import Vervis.Model.Workflow
+import Vervis.Ticket
 import Vervis.TicketFilter (TicketFilter (..))
 
 --TODO use custom fields to ensure uniqueness or other constraints?
 
-defTime :: UTCTime
-defTime = UTCTime (ModifiedJulianDay 0) 0
-
-now :: AForm Handler UTCTime
-now = lift $ liftIO getCurrentTime
-
 data NewTicket = NewTicket
     { ntTitle   :: Text
     , ntDesc    :: Text
@@ -138,8 +134,66 @@ editTicketContentAForm ticket = Ticket
     <*> pure (ticketCloser ticket)
     <*> pure (ticketDiscuss ticket)
 
-editTicketContentForm :: Ticket -> Form Ticket
-editTicketContentForm t = renderDivs $ editTicketContentAForm t
+tEditField
+    :: TicketTextParam
+    -> AForm Handler (Maybe TicketParamTextId, Maybe (WorkflowFieldId, Text))
+tEditField (TicketTextParam (WorkflowFieldSummary fid _ name req _) mv) =
+    let sets = fieldSettings name req
+    in  (ttpvId <$> mv, ) . fmap (fid, ) <$>
+        if req
+            then Just <$> areq textField sets (ttpvVal <$> mv)
+            else aopt textField sets (Just . ttpvVal <$> mv)
+
+eEditField
+    :: TicketEnumParam
+    -> AForm
+        Handler
+        ( Maybe TicketParamEnumId
+        , Maybe (WorkflowFieldId, WorkflowFieldEnumCtorId)
+        )
+eEditField (TicketEnumParam (WorkflowFieldSummary fid _ name req _) e mv) =
+    let sets = fieldSettings name req
+        sel =
+            selectField $
+            optionsPersistKey
+                [WorkflowFieldEnumCtorEnum ==. wesId e]
+                []
+                workflowFieldEnumCtorName
+    in  (tepvId <$> mv, ) . fmap (fid, ) <$>
+        if req
+            then Just <$> areq sel sets (tepvVal <$> mv)
+            else aopt sel sets (Just . tepvVal <$> mv)
+
+editTicketContentForm
+    :: TicketId
+    -> Ticket
+    -> WorkflowId
+    -> Form
+        ( Ticket
+        , [ ( Maybe TicketParamTextId
+            , Maybe (WorkflowFieldId, Text)
+            )
+          ]
+        , [ ( Maybe TicketParamEnumId
+            , Maybe (WorkflowFieldId, WorkflowFieldEnumCtorId)
+            )
+          ]
+        )
+editTicketContentForm tid t wid html = do
+    (tfs, efs) <-
+        lift $ runDB $
+        liftA2 (,)
+            ( filter (not . wfsConstant . ttpField) <$>
+                getTicketTextParams tid wid
+            )
+            ( filter (not . wfsConstant . tepField) <$>
+                getTicketEnumParams tid wid
+            )
+    flip renderDivs html $
+        liftA3 (,,)
+            (editTicketContentAForm t)
+            (traverse tEditField tfs)
+            (traverse eEditField efs)
 
 assignTicketAForm :: PersonId -> ProjectId -> AForm Handler PersonId
 assignTicketAForm pid jid =

src/Vervis/Handler/Ticket.hs

@@ -56,6 +56,7 @@ import Control.Applicative (liftA2)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (logWarn)
 import Data.Default.Class (def)
+import Data.Foldable (traverse_)
 import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Data.Text (Text)
@@ -76,6 +77,7 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
 import qualified Data.Text as T (filter, intercalate, pack)
 import qualified Database.Esqueleto as E ((==.))
 
+import Data.Maybe.Local (partitionMaybePairs)
 import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
 import Vervis.Form.Ticket
 import Vervis.Foundation
@@ -224,40 +226,8 @@ getTicketR shar proj num = do
                         person <- get404 $ ticketCloser ticket
                         get404 $ personIdent person
                     else return author
-            tparams <- 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 ^. 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
-                    )
+            tparams <- getTicketTextParams tid wid
+            eparams <- getTicketEnumParams tid wid
             deps <- select $ from $ \ (dep `InnerJoin` t) -> do
                 on $ dep ^. TicketDependencyChild ==. t ^. TicketId
                 where_ $ dep ^. TicketDependencyParent ==. val tid
@@ -277,19 +247,47 @@ 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
 putTicketR shar proj num = do
-    Entity tid ticket <- runDB $ do
+    (tid, ticket, wid) <- 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
+        Entity pid project <- getBy404 $ UniqueProject proj sid
+        Entity tid ticket <- getBy404 $ UniqueTicket pid num
+        return (tid, ticket, projectWorkflow project)
+    ((result, widget), enctype) <-
+        runFormPost $ editTicketContentForm tid ticket wid
     case result of
-        FormSuccess ticket' -> do
-            runDB $ replace tid ticket'
+        FormSuccess (ticket', tparams, eparams) -> do
+            runDB $ do
+                replace tid ticket'
+                let (tdel, tins, tupd) = partitionMaybePairs tparams
+                deleteWhere [TicketParamTextId <-. tdel]
+                let mktparam (fid, v) = TicketParamText
+                        { ticketParamTextTicket = tid
+                        , ticketParamTextField  = fid
+                        , ticketParamTextValue  = v
+                        }
+                insertMany_ $ map mktparam tins
+                traverse_
+                    (\ (aid, (_fid, v)) ->
+                        update aid [TicketParamTextValue =. v]
+                    )
+                    tupd
+                let (edel, eins, eupd) = partitionMaybePairs eparams
+                deleteWhere [TicketParamEnumId <-. edel]
+                let mkeparam (fid, v) = TicketParamEnum
+                        { ticketParamEnumTicket = tid
+                        , ticketParamEnumField  = fid
+                        , ticketParamEnumValue  = v
+                        }
+                insertMany_ $ map mkeparam eins
+                traverse_
+                    (\ (aid, (_fid, v)) ->
+                        update aid [TicketParamEnumValue =. v]
+                    )
+                    eupd
             setMessage "Ticket updated."
             redirect $ TicketR shar proj num
         FormMissing -> do
@@ -315,11 +313,13 @@ postTicketR shar proj num = do
 
 getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html
 getTicketEditR shar proj num = do
-    Entity _tid ticket <- runDB $ do
+    (tid, ticket, wid) <- 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
+        Entity pid project <- getBy404 $ UniqueProject proj sid
+        Entity tid ticket <- getBy404 $ UniqueTicket pid num
+        return (tid, ticket, projectWorkflow project)
+    ((_result, widget), enctype) <-
+        runFormPost $ editTicketContentForm tid ticket wid
     defaultLayout $(widgetFile "ticket/edit")
 
 postTicketCloseR :: ShrIdent -> PrjIdent -> Int -> Handler Html

src/Vervis/Ticket.hs

@@ -16,16 +16,27 @@
 module Vervis.Ticket
     ( getTicketSummaries
     , getTicketDepEdges
+    , WorkflowFieldSummary (..)
+    , TicketTextParamValue (..)
+    , TicketTextParam (..)
+    , getTicketTextParams
+    , WorkflowEnumSummary (..)
+    , TicketEnumParamValue (..)
+    , TicketEnumParam (..)
+    , getTicketEnumParams
     )
 where
 
 import Prelude
 
 import Control.Arrow ((***))
+import Data.Text (Text)
 import Database.Esqueleto
 
 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.
@@ -69,3 +80,172 @@ getTicketDepEdges jid =
             t2 ^. TicketProject ==. val jid
         orderBy [asc $ t1 ^. TicketNumber, asc $ t2 ^. TicketNumber]
         return (t1 ^. TicketNumber, t2 ^. TicketNumber)
+
+data WorkflowFieldSummary = WorkflowFieldSummary
+    { wfsId       :: WorkflowFieldId
+    , wfsIdent    :: FldIdent
+    , wfsName     :: Text
+    , wfsRequired :: Bool
+    , wfsConstant :: Bool
+    }
+
+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 (Maybe TicketParamTextId)
+       , Value (Maybe Text)
+       )
+    -> TicketTextParam
+toTParam
+    ( Value fid
+    , Value fld
+    , Value name
+    , Value req
+    , Value con
+    , Value mp
+    , Value mt
+    ) =
+        TicketTextParam
+            { ttpField = WorkflowFieldSummary
+                { wfsId       = fid
+                , wfsIdent    = fld
+                , wfsName     = name
+                , wfsRequired = req
+                , wfsConstant = con
+                }
+            , 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
+            , p ?. TicketParamTextId
+            , p ?. TicketParamTextValue
+            )
+
+data WorkflowEnumSummary = WorkflowEnumSummary
+    { wesId    :: WorkflowFieldEnumId
+    , wesIdent :: EnmIdent
+    }
+
+data TicketEnumParamValue = TicketEnumParamValue
+    { tepvId   :: TicketParamEnumId
+    , tepvVal  :: WorkflowFieldEnumCtorId
+    , tepvName :: Text
+    }
+
+data TicketEnumParam = TicketEnumParam
+    { tepField :: WorkflowFieldSummary
+    , tepEnum  :: WorkflowEnumSummary
+    , tepValue :: Maybe TicketEnumParamValue
+    }
+
+toEParam
+    :: ( Value WorkflowFieldId
+       , Value FldIdent
+       , Value Text
+       , Value Bool
+       , Value Bool
+       , Value WorkflowFieldEnumId
+       , Value EnmIdent
+       , Value (Maybe TicketParamEnumId)
+       , Value (Maybe WorkflowFieldEnumCtorId)
+       , Value (Maybe Text)
+       )
+    -> TicketEnumParam
+toEParam
+    ( Value fid
+    , Value fld
+    , Value name
+    , Value req
+    , Value con
+    , Value i
+    , Value e
+    , Value mp
+    , Value mc
+    , Value mt
+    ) =
+        TicketEnumParam
+            { tepField = WorkflowFieldSummary
+                { wfsId       = fid
+                , wfsIdent    = fld
+                , wfsName     = name
+                , wfsRequired = req
+                , wfsConstant = con
+                }
+            , 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 ^. WorkflowFieldEnumWorkflow ==. val wid &&.
+            f ^. WorkflowFieldEnm          ==. just (e ^. WorkflowFieldEnumId)
+        on $
+            f ^. WorkflowFieldWorkflow     ==. val wid                     &&.
+            f ^. WorkflowFieldType         ==. val WFTEnum                 &&.
+            p ?. TicketParamEnumField      ==. just (f ^. WorkflowFieldId) &&.
+            c ?. WorkflowFieldEnumCtorEnum ==. f ^. WorkflowFieldEnm
+        on $
+            p ?. TicketParamEnumTicket ==. just (val tid) &&.
+            p ?. TicketParamEnumValue  ==. c ?. WorkflowFieldEnumCtorId
+        return
+            ( f ^. WorkflowFieldId
+            , f ^. WorkflowFieldIdent
+            , f ^. WorkflowFieldName
+            , f ^. WorkflowFieldRequired
+            , f ^. WorkflowFieldConstant
+            , e ^. WorkflowFieldEnumId
+            , e ^. WorkflowFieldEnumIdent
+            , p ?. TicketParamEnumId
+            , c ?. WorkflowFieldEnumCtorId
+            , c ?. WorkflowFieldEnumCtorName
+            )

templates/ticket/one.hamlet

@@ -103,34 +103,31 @@ $if not $ ticketDone ticket
 <h3>Custom fields
 
 <ul>
-  $forall (Value fld, Value name, Value req, Value mvalue) <- tparams
+  $forall TicketTextParam field mvalue <- tparams
     <li>
-      <a href=@{WorkflowFieldR wshr wfl fld}>
-        #{name}
+      <a href=@{WorkflowFieldR wshr wfl $ wfsIdent field}>
+        #{wfsName field}
       :
       $maybe value <- mvalue
-        #{value}
+        #{ttpvVal value}
       $nothing
-        $if req
+        $if wfsRequired field
           NO VALUE FOR REQUIRED FIELD
         $else
           (none)
-  $forall (Value fld, Value name, Value req, Value me, Value mc) <- eparams
+  $forall TicketEnumParam field enum mvalue <- eparams
     <li>
-      <a href=@{WorkflowFieldR wshr wfl fld}>
-        #{name}
+      <a href=@{WorkflowFieldR wshr wfl $ wfsIdent field}>
+        #{wfsName field}
       :
-      $case (me, mc)
-        $of (Just e, Just c)
-          <a href=@{WorkflowEnumCtorsR wshr wfl e}>
-            #{c}
-        $of (Nothing, Nothing)
-          $if req
+      $maybe value <- mvalue
+        <a href=@{WorkflowEnumCtorsR wshr wfl $ wesIdent enum}>
+          #{tepvName value}
+      $nothing
+        $if wfsRequired field
           NO VALUE FOR REQUIRED FIELD
         $else
           (none)
-        $of _
-          #{error' "Impossible!"}
 
 <h3>Discussion
 

vervis.cabal

@@ -61,6 +61,7 @@ library
                        Data.HashMap.Lazy.Local
                        Data.Hourglass.Local
                        Data.List.Local
+                       Data.Maybe.Local
                        Data.Paginate.Local
                        Data.Revision.Local
                        Data.Text.UTF8.Local