Ticket dependency add/remove and some fixes to recursive SQL

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

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)

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)

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

src/Database/Persist/Sql/Graph/TransitiveReduction.hs

@@ -251,13 +251,14 @@ trrFix
        , SqlBackend ~ PersistEntityBackend node
        , SqlBackend ~ PersistEntityBackend edge
        )
-    => Key edge
+    => edge
-    -> Key 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

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 Data.Text (Text)
-import Yesod.Form.Fields (selectField, optionsPairs)
+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)

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

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
                                             )

src/Vervis/GraphProxy.hs

@@ -0,0 +1,45 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | 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

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

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

src/Vervis/Model/Role.hs

@@ -33,6 +33,8 @@ data ProjectOperation
     | ProjOpUnclaimTicket
     | ProjOpAssignTicket
     | ProjOpUnassignTicket
+    | ProjOpAddTicketDep
+    | ProjOpRemoveTicketDep
     deriving (Eq, Show, Read, Enum, Bounded)
 
 derivePersistField "ProjectOperation"

src/Vervis/Query.hs

@@ -71,16 +71,16 @@ getProjectRoleAncestorWithOpQ op role = do
             ProjectRoleInheritParent
             ProjectRoleInheritChild
             (\ temp -> mconcat
-                [ "SELECT ", qcols
+                [ "SELECT ??"
-                , " FROM ", dbname temp, ", ", tAcc
+                , " FROM ", dbname temp, " INNER JOIN ", tAcc
-                , " WHERE "
+                , " ON "
                 , dbname temp, ".", field ProjectRoleInheritParent
                 , " = "
                 , tAcc, ".", field ProjectAccessRole
-                , " AND "
+                , " WHERE "
                 , tAcc, ".", field ProjectAccessOp
-                , " = ? "
+                , " = ?"
-                , " LIMIT TO 1"
+                , " LIMIT 1"
                 ]
             )
             [toPersistValue op]

templates/ticket/dep/list.hamlet

@@ -18,6 +18,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Author
     <th>Title
     <th>Done
+    $if forward
+      <th>Remove dependency
   $forall (Value number, Entity _ author, Value title, Value done) <- rows
     <tr>
       <td>
@@ -28,3 +30,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
         <a href=@{TicketR shr prj number}>#{title}
       <td>
         #{done}
+      $if forward
+        <td>
+          <form method=POST action=@{TicketDepR shr prj num number}>
+            <input type=hidden name=_method value=DELETE>
+            <input type=submit value="Remove">
+
+$if forward
+  <p>
+    <a href=@{TicketDepNewR shr prj num}>
+      Add new…

templates/ticket/dep/new.hamlet

@@ -0,0 +1,17 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ 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
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<form method=POST action=@{TicketDepsR shr prj num} enctype=#{enctype}>
+  ^{widget}
+  <input type=submit>

vervis.cabal

@@ -119,6 +119,7 @@ library
                        Vervis.Foundation
                        Vervis.Git
                        Vervis.GitOld
+                       Vervis.GraphProxy
                        Vervis.Handler.Common
                        Vervis.Handler.Discussion
                        Vervis.Handler.Git