Dedicated NewTicket type for ticket creation

src/Vervis/Form/Ticket.hs

@@ -14,7 +14,8 @@
  -}
 
 module Vervis.Form.Ticket
-    ( newTicketForm
+    ( NewTicket (..)
+    , newTicketForm
     , editTicketForm
     )
 where
@@ -23,6 +24,7 @@ import Prelude
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
+import Data.Text (Text)
 import Data.Time.Calendar (Day (..))
 import Data.Time.Clock (getCurrentTime, UTCTime (..))
 import Yesod.Form
@@ -31,8 +33,6 @@ import Vervis.Foundation (Form, Handler)
 import Vervis.Model
 
 --TODO use custom fields to ensure uniqueness or other constraints?
---TODO stuff like number and created - do I generate them here using monadic
---     form or do I rely on handler to provide? which approach is better?
 
 defTime :: UTCTime
 defTime = UTCTime (ModifiedJulianDay 0) 0
@@ -40,22 +40,20 @@ defTime = UTCTime (ModifiedJulianDay 0) 0
 now :: AForm Handler UTCTime
 now = lift $ liftIO getCurrentTime
 
-newTicketAForm :: ProjectId -> Int -> PersonId -> AForm Handler Ticket
-newTicketAForm pid number author = Ticket
-    <$> pure pid
-    <*> pure number
-    <*> now
-    <*> pure author
-    <*> areq textField "Title*" Nothing
+data NewTicket = NewTicket
+    { ntTitle :: Text
+    , ntDesc  :: Text
+    }
+
+newTicketAForm :: AForm Handler NewTicket
+newTicketAForm = NewTicket
+    <$> areq textField "Title*" Nothing
     <*> ( maybe "" unTextarea <$>
           aopt textareaField "Description (Markdown)" Nothing
         )
-    <*> pure False
-    <*> pure defTime
-    <*> pure author
 
-newTicketForm :: ProjectId -> Int -> PersonId -> Form Ticket
-newTicketForm pid number author = renderDivs $ newTicketAForm pid number author
+newTicketForm :: Form NewTicket
+newTicketForm = renderDivs newTicketAForm
 
 editTicketAForm :: Ticket -> PersonId -> AForm Handler Ticket
 editTicketAForm ticket pid = fmap fixDone $ Ticket

src/Vervis/Handler/Ticket.hs

@@ -27,8 +27,11 @@ where
 
 import Prelude
 
+import Control.Monad.IO.Class (liftIO)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
+import Data.Time.Calendar (Day (..))
+import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Data.Time.Format (formatTime, defaultTimeLocale)
 import Database.Esqueleto hiding ((==.), (+=.), update)
 import Database.Persist
@@ -71,19 +74,31 @@ getTicketsR shar proj = do
 
 postTicketsR :: Text -> Text -> Handler Html
 postTicketsR shar proj = do
-    Entity pid project <- runDB $ do
-        Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
-        getBy404 $ UniqueProject proj sid
-    let next = projectNextTicket project
-    author <- requireAuthId
-    ((result, widget), enctype) <- runFormPost $ newTicketForm pid next author
+    ((result, widget), enctype) <- runFormPost newTicketForm {-pid next author-}
     case result of
-        FormSuccess ticket -> do
-            runDB $ do
+        FormSuccess nt -> do
+            author <- requireAuthId
+            now <- liftIO getCurrentTime
+            tnum <- runDB $ do
+                Entity pid project <- do
+                    Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
+                    getBy404 $ UniqueProject proj sid
+                let ticket = Ticket
+                        { ticketProject = pid
+                        , ticketNumber  = projectNextTicket project
+                        , ticketCreated = now
+                        , ticketCreator = author
+                        , ticketTitle   = ntTitle nt
+                        , ticketDesc    = ntDesc nt
+                        , ticketDone    = False
+                        , ticketClosed  = UTCTime (ModifiedJulianDay 0) 0
+                        , ticketCloser  = author
+                        }
                 update pid [ProjectNextTicket +=. 1]
                 insert_ ticket
+                return $ ticketNumber ticket
             setMessage "Ticket created."
-            redirect $ TicketR shar proj (ticketNumber ticket)
+            redirect $ TicketR shar proj tnum
         FormMissing -> do
             setMessage "Field(s) missing."
             defaultLayout $(widgetFile "ticket/new")
@@ -93,15 +108,8 @@ postTicketsR shar proj = do
 
 getTicketNewR :: Text -> Text -> Handler Html
 getTicketNewR shar proj = do
-    Entity pid project <- runDB $ do
-        Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
-        getBy404 $ UniqueProject proj sid
-    let next = projectNextTicket project
-    author <- requireAuthId
-    ((_result, widget), enctype) <- runFormPost $ newTicketForm pid next author
-    defaultLayout $ do
-        setTitle $ toHtml $ T.intercalate " :: " [shar, proj, "New ticket"]
-        $(widgetFile "ticket/new")
+    ((_result, widget), enctype) <- runFormPost newTicketForm
+    defaultLayout $(widgetFile "ticket/new")
 
 getTicketR :: Text -> Text -> Int -> Handler Html
 getTicketR shar proj num = do