diff --git a/config/models b/config/models index 856c225..96826ff 100644 --- a/config/models +++ b/config/models @@ -72,5 +72,7 @@ Ticket title Text desc Text -- Assume this is Pandoc Markdown done Bool + closed UTCTime + closer PersonId UniqueTicket project number diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 0620c53..0d33c1d 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -15,6 +15,7 @@ module Vervis.Form.Ticket ( newTicketForm + , editTicketForm ) where @@ -22,7 +23,8 @@ import Prelude import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) -import Data.Time.Clock (getCurrentTime) +import Data.Time.Calendar (Day (..)) +import Data.Time.Clock (getCurrentTime, UTCTime (..)) import Yesod.Form import Vervis.Foundation (Form, Handler) @@ -32,15 +34,53 @@ import Vervis.Model --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 + +now :: AForm Handler UTCTime +now = lift $ liftIO getCurrentTime + newTicketAForm :: ProjectId -> Int -> PersonId -> AForm Handler Ticket newTicketAForm pid number author = Ticket <$> pure pid <*> pure number - <*> lift (liftIO getCurrentTime) + <*> now <*> pure author <*> areq textField "Title*" Nothing - <*> (maybe "" unTextarea <$> aopt textareaField "Description (Markdown)" 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 + +editTicketAForm :: Ticket -> PersonId -> AForm Handler Ticket +editTicketAForm ticket pid = fmap fixDone $ Ticket + <$> pure (ticketProject ticket) + <*> pure (ticketNumber ticket) + <*> pure (ticketCreated ticket) + <*> pure (ticketCreator ticket) + <*> areq textField "Title*" (Just $ ticketTitle ticket) + <*> ( maybe "" unTextarea <$> + aopt + textareaField + "Description (Markdown)" + (Just $ Just $ Textarea $ ticketDesc ticket) + ) + <*> areq checkBoxField "Done*" (Just $ ticketDone ticket) + <*> now + <*> pure (ticketCloser ticket) + where + fixDone result = case (ticketDone ticket, ticketDone result) of + (True, True) -> result { ticketClosed = ticketClosed ticket } + (False, False) -> result { ticketClosed = ticketClosed ticket } + (False, True) -> result { ticketCloser = pid } + (True, False) -> result { ticketClosed = defTime + , ticketCloser = ticketCreator ticket + } + +editTicketForm :: Ticket -> PersonId -> Form Ticket +editTicketForm t p = renderDivs $ editTicketAForm t p diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 0ff9795..96d7cda 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -116,6 +116,10 @@ instance Yesod App where isAuthorized (KeyNewR user) _ = loggedInAs user "You can’t add keys for other users" isAuthorized (TicketNewR _ _) _ = loggedIn + isAuthorized (TicketR user _ _) True = + loggedInAs user "Only project members can modify this ticket" + isAuthorized (TicketEditR user _ _) _ = + loggedInAs user "Only project members can modify this ticket" isAuthorized _ _ = return Authorized -- This function creates static content files in the static folder diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 28a25b8..ed97b15 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -34,7 +34,7 @@ import Database.Persist import Text.Blaze.Html (Html, toHtml) import Yesod.Auth (requireAuthId) import Yesod.Core (defaultLayout) -import Yesod.Core.Handler (redirectUltDest, setMessage) +import Yesod.Core.Handler (setMessage, redirect) import Yesod.Core.Widget (setTitle) import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) @@ -50,10 +50,6 @@ import Vervis.Settings (widgetFile) getTicketsR :: Text -> Text -> Handler Html getTicketsR shar proj = do - --tickets <- runDB $ do - -- Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar - -- Entity pid _project <- getBy404 $ UniqueProject proj sid - -- selectList [TicketProject ==. pid] [Asc TicketNumber] rows <- runDB $ select $ from $ \ (ticket, person, sharer) -> do where_ $ ticket ^. TicketCreator E.==. person ^. PersonId &&. @@ -84,7 +80,7 @@ postTicketsR shar proj = do update pid [ProjectNextTicket +=. 1] insert_ ticket setMessage "Ticket created." - redirectUltDest HomeR + redirect $ TicketR shar proj (ticketNumber ticket) FormMissing -> do setMessage "Field(s) missing." defaultLayout $(widgetFile "ticket/new") @@ -106,23 +102,59 @@ getTicketNewR shar proj = do getTicketR :: Text -> Text -> Int -> Handler Html getTicketR shar proj num = do - (author, ticket) <- runDB $ do + (author, closer, ticket) <- runDB $ do Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar Entity pid _project <- getBy404 $ UniqueProject proj sid Entity _tid ticket <- getBy404 $ UniqueTicket pid num person <- get404 $ ticketCreator ticket author <- get404 $ personIdent person - return (author, ticket) + closer <- + if ticketDone ticket + then do + person' <- get404 $ ticketCloser ticket + get404 $ personIdent person' + else return author + return (author, closer, ticket) defaultLayout $ do setTitle $ toHtml $ T.intercalate " :: " [shar, proj, "Tickets", T.pack ('#' : show num)] $(widgetFile "ticket/one") putTicketR :: Text -> Text -> Int -> Handler Html -putTicketR shar proj num = error "Not implemented" +putTicketR shar proj num = do + Entity tid ticket <- runDB $ do + Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity pid _project <- getBy404 $ UniqueProject proj sid + getBy404 $ UniqueTicket pid num + user <- requireAuthId + ((result, widget), enctype) <- runFormPost $ editTicketForm ticket user + case result of + FormSuccess ticket' -> do + runDB $ replace tid ticket' + setMessage "Ticket created." + redirect $ TicketR shar proj num + FormMissing -> do + setMessage "Field(s) missing." + defaultLayout $(widgetFile "ticket/edit") + FormFailure _l -> do + setMessage "Ticket update failed, see errors below." + defaultLayout $(widgetFile "ticket/edit") deleteTicketR :: Text -> Text -> Int -> Handler Html -deleteTicketR shar proj num = error "Not implemented" +deleteTicketR shar proj num = + --TODO: I can easily implement this, but should it even be possible to + --delete tickets? + error "Not implemented" getTicketEditR :: Text -> Text -> Int -> Handler Html -getTicketEditR shar proj num = error "Not implemented" +getTicketEditR shar proj num = do + Entity _tid ticket <- runDB $ do + Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity pid _project <- getBy404 $ UniqueProject proj sid + getBy404 $ UniqueTicket pid num + user <- requireAuthId + ((_result, widget), enctype) <- runFormPost $ editTicketForm ticket user + defaultLayout $ do + setTitle $ toHtml $ T.intercalate " :: " + [shar, proj, "Tickets", T.pack ('#' : show num), "Edit"] + $(widgetFile "ticket/edit") diff --git a/templates/ticket/edit.hamlet b/templates/ticket/edit.hamlet new file mode 100644 index 0000000..e1e33eb --- /dev/null +++ b/templates/ticket/edit.hamlet @@ -0,0 +1,21 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +

#{shar} :: #{proj} :: Tickets :: ##{num} :: Edit + +Enter the details and click "Submit" to update the ticket. + +
+ ^{widget} + diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 022d74b..22e4bf8 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -24,7 +24,13 @@ $# . Created on #{formatTime defaultTimeLocale "%F" $ ticketCreated ticket} by #{fromMaybe (sharerIdent author) $ sharerName author} -

Done: #{ticketDone ticket} +

+ Status: + $if ticketDone ticket + Closed on #{formatTime defaultTimeLocale "%F" $ ticketClosed ticket} by + #{fromMaybe (sharerIdent closer) $ sharerName closer} + $else + Open

#{ticketTitle ticket}