forge/Vervis
1
0
Fork 0
Code Pull requests Activity

New ticket creation via POST

Browse source
This commit is contained in:
fr33domlover 2016-05-01 10:15:38 +00:00
parent 7a4b211617
commit 4f6ccf8f4a
1 changed files with 23 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
src/Vervis/Handler/Ticket.hs
View file

@ -26,14 +26,15 @@ import Prelude
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Time.Format (formatTime, defaultTimeLocale)
import Database.Esqueleto hiding ((==.)) import Database.Esqueleto hiding ((==.), (+=.), update)
import Database.Persist import Database.Persist
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
import Yesod.Auth (requireAuthId) import Yesod.Auth (requireAuthId)
import Yesod.Core (defaultLayout) import Yesod.Core (defaultLayout)
import Yesod.Core.Handler (notFound) import Yesod.Core.Handler (redirectUltDest, setMessage)
import Yesod.Core.Widget (setTitle) import Yesod.Core.Widget (setTitle)
import Yesod.Form.Functions (runFormPost) import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404) import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Data.Text as T (intercalate, pack) import qualified Data.Text as T (intercalate, pack)
@ -67,7 +68,26 @@ getTicketsR shar proj = do
$(widgetFile "ticket/list") $(widgetFile "ticket/list")
postTicketsR :: Text -> Text -> Handler Html postTicketsR :: Text -> Text -> Handler Html
postTicketsR shar proj = notFound 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
case result of
FormSuccess ticket -> do
runDB $ do
update pid [ProjectNextTicket +=. 1]
insert_ ticket
setMessage "Ticket created."
redirectUltDest HomeR
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/new")
FormFailure _l -> do
setMessage "Ticket creation failed, see errors below."
defaultLayout $(widgetFile "ticket/new")
getTicketNewR :: Text -> Text -> Handler Html getTicketNewR :: Text -> Text -> Handler Html
getTicketNewR shar proj = do getTicketNewR shar proj = do