From 5c153b02949ff53a1f947caf2102aef4cbbc4ed8 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 28 Jul 2016 16:40:10 +0000 Subject: [PATCH] Ticket dependency add/remove and some fixes to recursive SQL --- config/routes | 4 +- .../Persist/Local/Class/PersistEntityGraph.hs | 2 + src/Database/Persist/Local/Sql.hs | 20 +++++- src/Database/Persist/Sql/Graph/Connects.hs | 6 +- .../Persist/Sql/Graph/TransitiveReduction.hs | 9 +-- src/Vervis/Field/Ticket.hs | 34 +++++++++- src/Vervis/Form/Ticket.hs | 7 +++ src/Vervis/Foundation.hs | 9 +++ src/Vervis/GraphProxy.hs | 45 +++++++++++++ src/Vervis/Handler/Ticket.hs | 63 ++++++++++++++++++- src/Vervis/Model.hs | 7 +++ src/Vervis/Model/Role.hs | 2 + src/Vervis/Query.hs | 12 ++-- templates/ticket/dep/list.hamlet | 12 ++++ templates/ticket/dep/new.hamlet | 17 +++++ vervis.cabal | 1 + 16 files changed, 231 insertions(+), 19 deletions(-) create mode 100644 src/Vervis/GraphProxy.hs create mode 100644 templates/ticket/dep/new.hamlet diff --git a/config/routes b/config/routes index 2629f29..372a773 100644 --- a/config/routes +++ b/config/routes @@ -109,7 +109,9 @@ /s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int TicketMessageR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int/reply TicketReplyR GET -/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET +/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST +/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET +/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepR POST DELETE /s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET diff --git a/src/Database/Persist/Local/Class/PersistEntityGraph.hs b/src/Database/Persist/Local/Class/PersistEntityGraph.hs index 3fedea3..148f0fe 100644 --- a/src/Database/Persist/Local/Class/PersistEntityGraph.hs +++ b/src/Database/Persist/Local/Class/PersistEntityGraph.hs @@ -23,5 +23,7 @@ import Prelude import Database.Persist class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where + sourceParam :: e -> Key n sourceField :: EntityField e (Key n) + destParam :: e -> Key n destField :: EntityField e (Key n) diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs index e8a8249..bbadf23 100644 --- a/src/Database/Persist/Local/Sql.hs +++ b/src/Database/Persist/Local/Sql.hs @@ -18,6 +18,8 @@ module Database.Persist.Local.Sql , rawSqlWithGraph , dummyFromFst , dummyFromSnd + , destParamFromProxy + , sourceParamFromProxy , destFieldFromProxy , sourceFieldFromProxy , (?:) @@ -27,7 +29,7 @@ where import Prelude -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (ReaderT, ask) import Data.Int (Int64) import Data.Monoid ((<>)) @@ -37,7 +39,7 @@ import Database.Persist import Database.Persist.Sql import Database.Persist.Sql.Util -import qualified Data.Text as T (null, intercalate) +import qualified Data.Text as T (null, unpack, intercalate) import Database.Persist.Local.Class.PersistEntityGraph import Database.Persist.Local.Class.PersistQueryForest @@ -55,6 +57,20 @@ dummyFromFst _ = Nothing dummyFromSnd :: Proxy (a, b) -> Maybe b dummyFromSnd _ = Nothing +destParamFromProxy + :: PersistEntityGraph node edge + => Proxy (node, edge) + -> edge + -> Key node +destParamFromProxy _ = destParam + +sourceParamFromProxy + :: PersistEntityGraph node edge + => Proxy (node, edge) + -> edge + -> Key node +sourceParamFromProxy _ = sourceParam + destFieldFromProxy :: PersistEntityGraph node edge => Proxy (node, edge) diff --git a/src/Database/Persist/Sql/Graph/Connects.hs b/src/Database/Persist/Sql/Graph/Connects.hs index a5a9150..f8e1465 100644 --- a/src/Database/Persist/Sql/Graph/Connects.hs +++ b/src/Database/Persist/Sql/Graph/Connects.hs @@ -157,7 +157,7 @@ xmconnectsm' follow filter msource mdest mlen proxy = do Just _ -> mconcat [ " FROM ", dbname $ entityDB tNode , " WHERE ", entityDB tNode ^* fieldDB (entityId tNode) - , " IN ?" + , " = ANY(?)" ] , " UNION ALL " , case follow of @@ -174,10 +174,10 @@ xmconnectsm' follow filter msource mdest mlen proxy = do , " FROM ", dbname temp , case mdest of Nothing -> "" - Just _ -> " WHERE ", temp ^* tid, " IN ?" + Just _ -> " WHERE " <> temp ^* tid <> " = ANY(?)" , case mlen of Nothing -> "" - Just _ -> " AND array_length(", temp ^* tpath, ", 1) <= ?" + Just _ -> " AND array_length(" <> temp ^* tpath <> ", 1) <= ?" , " )" ] toP = fmap toPersistValue diff --git a/src/Database/Persist/Sql/Graph/TransitiveReduction.hs b/src/Database/Persist/Sql/Graph/TransitiveReduction.hs index f995b0b..c361f94 100644 --- a/src/Database/Persist/Sql/Graph/TransitiveReduction.hs +++ b/src/Database/Persist/Sql/Graph/TransitiveReduction.hs @@ -251,13 +251,14 @@ trrFix , SqlBackend ~ PersistEntityBackend node , SqlBackend ~ PersistEntityBackend edge ) - => Key edge - -> Key edge + => edge -> Proxy (node, edge) -> ReaderT SqlBackend m Int64 -trrFix from to proxy = do +trrFix edge proxy = do conn <- ask - let tNode = entityDef $ dummyFromFst proxy + let from = sourceParamFromProxy proxy edge + to = destParamFromProxy proxy edge + tNode = entityDef $ dummyFromFst proxy tEdge = entityDef $ dummyFromSnd proxy fwd = persistFieldDef $ destFieldFromProxy proxy bwd = persistFieldDef $ sourceFieldFromProxy proxy diff --git a/src/Vervis/Field/Ticket.hs b/src/Vervis/Field/Ticket.hs index b3eb75f..e65deb4 100644 --- a/src/Vervis/Field/Ticket.hs +++ b/src/Vervis/Field/Ticket.hs @@ -15,18 +15,26 @@ module Vervis.Field.Ticket ( selectAssigneeFromProject + , selectTicketDep ) where import Prelude import Control.Arrow ((***)) -import Database.Esqueleto -import Yesod.Form.Fields (selectField, optionsPairs) +import Data.Text (Text) +import Database.Esqueleto hiding ((%)) +import Formatting +import Yesod.Form.Fields (selectField, optionsPairs, optionsPersistKey) +import Yesod.Form.Functions (checkBool, checkM) import Yesod.Form.Types (Field) import Yesod.Persist.Core (runDB) +import qualified Database.Persist as P + +import Database.Persist.Sql.Graph.Connects (uconnects) import Vervis.Foundation (Handler) +import Vervis.GraphProxy (ticketDepGraph) import Vervis.Model import Vervis.Model.Ident (shr2text) @@ -44,3 +52,25 @@ selectAssigneeFromProject pid jid = selectField $ do person ^. PersonId !=. val pid return (sharer ^. SharerIdent, person ^. PersonId) optionsPairs $ map (shr2text . unValue *** unValue) l + +checkNotSelf :: TicketId -> Field Handler TicketId -> Field Handler TicketId +checkNotSelf tidP = + checkBool (/= tidP) ("A ticket can’t depend on itself" :: Text) + +checkDep :: TicketId -> Field Handler TicketId -> Field Handler TicketId +checkDep tidP = checkM $ \ tidC -> do + uconn <- runDB $ uconnects tidP tidC Nothing ticketDepGraph + return $ if uconn + then Left ("There is already a dependency between the tickets" :: Text) + else Right tidC + +-- | Select a ticket from a project, but exclude the given ticket ID. When +-- processing the form, verify there is no depedndency between the tickets +-- (i.e. neither is reachable from the other). +selectTicketDep :: ProjectId -> TicketId -> Field Handler TicketId +selectTicketDep jid tid = + checkDep tid $ + checkNotSelf tid $ + selectField $ + optionsPersistKey [TicketProject P.==. jid, TicketId P.!=. tid] [] $ + \ t -> sformat (int % " :: " % stext) (ticketNumber t) (ticketTitle t) diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 3ec5d81..cb78a16 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -20,6 +20,7 @@ module Vervis.Form.Ticket , assignTicketForm , claimRequestForm , ticketFilterForm + , ticketDepForm ) where @@ -104,3 +105,9 @@ ticketFilterAForm = TicketFilter ticketFilterForm :: Form TicketFilter ticketFilterForm = renderDivs ticketFilterAForm + +ticketDepAForm :: ProjectId -> TicketId -> AForm Handler TicketId +ticketDepAForm jid tid = areq (selectTicketDep jid tid) "Dependency" Nothing + +ticketDepForm :: ProjectId -> TicketId -> Form TicketId +ticketDepForm jid tid = renderDivs $ ticketDepAForm jid tid diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a75dfb4..48a26dc 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -178,6 +178,9 @@ instance Yesod App where (TicketMessageR _ _ _ _ , True) -> personAny (TicketTopReplyR _ _ _ , _ ) -> personAny (TicketReplyR _ _ _ _ , _ ) -> personAny + (TicketDepsR s j _ , True) -> projOp ProjOpAddTicketDep s j + (TicketDepNewR s j _ , _ ) -> projOp ProjOpAddTicketDep s j + (TicketDepR s j _ _ , True) -> projOp ProjOpRemoveTicketDep s j _ -> return Authorized where nobody :: Handler AuthResult @@ -495,6 +498,12 @@ instance YesodBreadcrumbs App where TicketDepsR shr prj num -> ( "Dependencies" , Just $ TicketR shr prj num ) + TicketDepNewR shr prj num -> ( "New dependency" + , Just $ TicketDepsR shr prj num + ) + TicketDepR shr prj pnum cnum -> ( T.pack $ '#' : show cnum + , Just $ TicketDepsR shr prj pnum + ) TicketReverseDepsR shr prj num -> ( "Dependants" , Just $ TicketR shr prj num ) diff --git a/src/Vervis/GraphProxy.hs b/src/Vervis/GraphProxy.hs new file mode 100644 index 0000000..1c3b23d --- /dev/null +++ b/src/Vervis/GraphProxy.hs @@ -0,0 +1,45 @@ +{- 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 + - . + -} + +-- | Persistent graphs are specified using the 'PersistEntityGraph' typeclass, +-- using value functions which specify fields. But the DB schema is known at +-- development time, and a specific graph needs to be picked statically. Since +-- the 'persistent' package doesn't have compile-time (e.g. type-level) +-- representation of the schema (but instead converts from TH directly to +-- datatypes), the graph related functions use a 'Proxy' which specifies the +-- graph using the type. +-- +-- I don't know enough about type systems and advanced type features and GHC +-- extensions, to tell whether a better solution is possible. For now, this is +-- how things work. +-- +-- This module is a helper for easily specifying graphs instead of typing the +-- proxy type directly each time, which may be long and cumbersome. +module Vervis.GraphProxy + ( GraphProxy + , ticketDepGraph + ) +where + +import Prelude + +import Data.Proxy + +import Vervis.Model + +type GraphProxy n e = Proxy (n, e) + +ticketDepGraph :: GraphProxy Ticket TicketDependency +ticketDepGraph = Proxy diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 76c8dca..6177df4 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -41,6 +41,10 @@ module Vervis.Handler.Ticket , getTicketTopReplyR , getTicketReplyR , getTicketDepsR + , postTicketDepsR + , getTicketDepNewR + , postTicketDepR + , deleteTicketDepR , getTicketReverseDepsR ) where @@ -57,7 +61,7 @@ import Data.Time.Calendar (Day (..)) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Traversable (for) -import Database.Esqueleto hiding ((==.), (=.), (+=.), update) +import Database.Esqueleto hiding ((==.), (=.), (+=.), update, delete) import Database.Persist import Text.Blaze.Html (Html, toHtml) import Yesod.Auth (requireAuthId, maybeAuthId) @@ -70,9 +74,11 @@ import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Data.Text as T (filter, intercalate, pack) import qualified Database.Esqueleto as E ((==.)) +import Database.Persist.Sql.Graph.TransitiveReduction (trrFix) import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Handler.Discussion +import Vervis.GraphProxy (ticketDepGraph) import Vervis.MediaType (MediaType (Markdown)) import Vervis.Model import Vervis.Model.Ident @@ -576,5 +582,60 @@ getTicketDeps forward shr prj num = do getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketDepsR = getTicketDeps True +postTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html +postTicketDepsR shr prj num = do + (jid, tid) <- runDB $ do + Entity sid _ <- getBy404 $ UniqueSharer shr + Entity jid _ <- getBy404 $ UniqueProject prj sid + Entity tid _ <- getBy404 $ UniqueTicket jid num + return (jid, tid) + ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid + case result of + FormSuccess ctid -> do + runDB $ do + let td = TicketDependency + { ticketDependencyParent = tid + , ticketDependencyChild = ctid + } + insert_ td + trrFix td ticketDepGraph + setMessage "Ticket dependency added." + redirect $ TicketR shr prj num + FormMissing -> do + setMessage "Field(s) missing." + defaultLayout $(widgetFile "ticket/dep/new") + FormFailure _l -> do + setMessage "Submission failed, see errors below." + defaultLayout $(widgetFile "ticket/dep/new") + +getTicketDepNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html +getTicketDepNewR shr prj num = do + (jid, tid) <- runDB $ do + Entity sid _ <- getBy404 $ UniqueSharer shr + Entity jid _ <- getBy404 $ UniqueProject prj sid + Entity tid _ <- getBy404 $ UniqueTicket jid num + return (jid, tid) + ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid + defaultLayout $(widgetFile "ticket/dep/new") + +postTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html +postTicketDepR shr prj pnum cnum = do + mmethod <- lookupPostParam "_method" + case mmethod of + Just "DELETE" -> deleteTicketDepR shr prj pnum cnum + _ -> notFound + +deleteTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html +deleteTicketDepR shr prj pnum cnum = do + runDB $ do + Entity sid _ <- getBy404 $ UniqueSharer shr + Entity jid _ <- getBy404 $ UniqueProject prj sid + Entity ptid _ <- getBy404 $ UniqueTicket jid pnum + Entity ctid _ <- getBy404 $ UniqueTicket jid cnum + Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid + delete tdid + setMessage "Ticket dependency removed." + redirect $ TicketDepsR shr prj pnum + getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketReverseDepsR = getTicketDeps False diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 255e114..b86e9da 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -24,6 +24,7 @@ import Database.Persist.Quasi import Database.Persist.Sql (fromSqlKey) import Yesod.Auth.HashDB (HashDBUser (..)) +import Database.Persist.Local.Class.PersistEntityGraph import Vervis.Model.Group import Vervis.Model.Ident import Vervis.Model.Repo @@ -53,3 +54,9 @@ instance Hashable RepoRoleId where instance Hashable ProjectRoleId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey + +instance PersistEntityGraph Ticket TicketDependency where + sourceParam = ticketDependencyParent + sourceField = TicketDependencyParent + destParam = ticketDependencyChild + destField = TicketDependencyChild diff --git a/src/Vervis/Model/Role.hs b/src/Vervis/Model/Role.hs index cc6bce4..730de6e 100644 --- a/src/Vervis/Model/Role.hs +++ b/src/Vervis/Model/Role.hs @@ -33,6 +33,8 @@ data ProjectOperation | ProjOpUnclaimTicket | ProjOpAssignTicket | ProjOpUnassignTicket + | ProjOpAddTicketDep + | ProjOpRemoveTicketDep deriving (Eq, Show, Read, Enum, Bounded) derivePersistField "ProjectOperation" diff --git a/src/Vervis/Query.hs b/src/Vervis/Query.hs index b726d6c..1968d16 100644 --- a/src/Vervis/Query.hs +++ b/src/Vervis/Query.hs @@ -71,16 +71,16 @@ getProjectRoleAncestorWithOpQ op role = do ProjectRoleInheritParent ProjectRoleInheritChild (\ temp -> mconcat - [ "SELECT ", qcols - , " FROM ", dbname temp, ", ", tAcc - , " WHERE " + [ "SELECT ??" + , " FROM ", dbname temp, " INNER JOIN ", tAcc + , " ON " , dbname temp, ".", field ProjectRoleInheritParent , " = " , tAcc, ".", field ProjectAccessRole - , " AND " + , " WHERE " , tAcc, ".", field ProjectAccessOp - , " = ? " - , " LIMIT TO 1" + , " = ?" + , " LIMIT 1" ] ) [toPersistValue op] diff --git a/templates/ticket/dep/list.hamlet b/templates/ticket/dep/list.hamlet index 2425466..932403d 100644 --- a/templates/ticket/dep/list.hamlet +++ b/templates/ticket/dep/list.hamlet @@ -18,6 +18,8 @@ $# . Author Title Done + $if forward + Remove dependency $forall (Value number, Entity _ author, Value title, Value done) <- rows @@ -28,3 +30,13 @@ $# . #{title} #{done} + $if forward + +
+ + + +$if forward +

+ + Add new… diff --git a/templates/ticket/dep/new.hamlet b/templates/ticket/dep/new.hamlet new file mode 100644 index 0000000..49c13a8 --- /dev/null +++ b/templates/ticket/dep/new.hamlet @@ -0,0 +1,17 @@ +$# 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 +$# . + + + ^{widget} + diff --git a/vervis.cabal b/vervis.cabal index d2a9a8c..402a407 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -119,6 +119,7 @@ library Vervis.Foundation Vervis.Git Vervis.GitOld + Vervis.GraphProxy Vervis.Handler.Common Vervis.Handler.Discussion Vervis.Handler.Git