Include custom ticket text fields in new ticket form

src/Vervis/Form/Ticket.hs

@@ -28,14 +28,20 @@ import Prelude
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
+import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Data.Time.Calendar (Day (..))
 import Data.Time.Clock (getCurrentTime, UTCTime (..))
+import Database.Persist
 import Yesod.Form
+import Yesod.Persist.Core (runDB)
+
+import qualified Data.Text as T (snoc)
 
 import Vervis.Field.Ticket
-import Vervis.Foundation (Form, Handler)
+import Vervis.Foundation (App, Form, Handler)
 import Vervis.Model
+import Vervis.Model.Workflow
 import Vervis.TicketFilter (TicketFilter (..))
 
 --TODO use custom fields to ensure uniqueness or other constraints?
@@ -47,19 +53,39 @@ now :: AForm Handler UTCTime
 now = lift $ liftIO getCurrentTime
 
 data NewTicket = NewTicket
-    { ntTitle :: Text
-    , ntDesc  :: Text
+    { ntTitle   :: Text
+    , ntDesc    :: Text
+    , ntTParams :: [(WorkflowFieldId, Text)]
     }
 
-newTicketAForm :: AForm Handler NewTicket
-newTicketAForm = NewTicket
-    <$> areq textField "Title*" Nothing
-    <*> ( maybe "" unTextarea <$>
-          aopt textareaField "Description (Markdown)" Nothing
-        )
+tfieldSettings :: Text -> Bool -> FieldSettings App
+tfieldSettings name req =
+    fieldSettingsLabel $
+    if req
+        then name `T.snoc` '*'
+        else name
 
-newTicketForm :: Form NewTicket
-newTicketForm = renderDivs newTicketAForm
+tfield :: Entity WorkflowField -> AForm Handler (Maybe (WorkflowFieldId, Text))
+tfield (Entity fid f) =
+    let sets = tfieldSettings (workflowFieldName f) (workflowFieldRequired f)
+    in  fmap (fid, ) <$>
+        if workflowFieldRequired f
+            then Just <$> areq textField sets Nothing
+            else aopt textField sets Nothing
+
+newTicketForm :: WorkflowId -> Form NewTicket
+newTicketForm wid html = do
+    tfs <-
+        lift $ runDB $
+        selectList
+            [WorkflowFieldWorkflow ==. wid, WorkflowFieldType ==. WFTText]
+            []
+    flip renderDivs html $ NewTicket
+        <$> areq textField "Title*" Nothing
+        <*> ( maybe "" unTextarea <$>
+              aopt textareaField "Description (Markdown)" Nothing
+            )
+        <*> (catMaybes <$> traverse tfield tfs)
 
 editTicketContentAForm :: Ticket -> AForm Handler Ticket
 editTicketContentAForm ticket = Ticket

src/Vervis/Handler/Ticket.hs

@@ -120,15 +120,16 @@ getTicketsR shar proj = do
 
 postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
 postTicketsR shar proj = do
-    ((result, widget), enctype) <- runFormPost newTicketForm
+    Entity pid project <- runDB $ do
+        Entity sid _sharer <- getBy404 $ UniqueSharer shar
+        getBy404 $ UniqueProject proj sid
+    ((result, widget), enctype) <-
+        runFormPost $ newTicketForm $ projectWorkflow project
     case result of
         FormSuccess nt -> do
             author <- requireAuthId
             now <- liftIO getCurrentTime
             tnum <- runDB $ do
-                Entity pid project <- do
-                    Entity sid _sharer <- getBy404 $ UniqueSharer shar
-                    getBy404 $ UniqueProject proj sid
                 update pid [ProjectNextTicket +=. 1]
                 let discussion = Discussion
                         { discussionNextMessage = 1
@@ -147,7 +148,13 @@ postTicketsR shar proj = do
                         , ticketCloser   = author
                         , ticketDiscuss  = did
                         }
-                insert_ ticket
+                tid <- insert ticket
+                let mkparam (fid, v) = TicketParamText
+                        { ticketParamTextTicket = tid
+                        , ticketParamTextField  = fid
+                        , ticketParamTextValue  = v
+                        }
+                insertMany_ $ map mkparam $ ntTParams nt
                 return $ ticketNumber ticket
             setMessage "Ticket created."
             redirect $ TicketR shar proj tnum
@@ -170,7 +177,11 @@ getTicketTreeR shr prj = do
 
 getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
 getTicketNewR shar proj = do
-    ((_result, widget), enctype) <- runFormPost newTicketForm
+    wid <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shar
+        Entity _   j <- getBy404 $ UniqueProject proj sid
+        return $ projectWorkflow j
+    ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
     defaultLayout $(widgetFile "ticket/new")
 
 getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html