diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index a9c0b1d..cec2f5b 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/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 = diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 5c9d4d8..1ccd6c9 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 0720a88..8f7150d 100644 --- a/src/Vervis/Ticket.hs +++ b/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 + ) diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 741bd77..d4ddcd9 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -103,34 +103,31 @@ $if not $ ticketDone ticket

Custom fields