Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev
[gargantext.git] / src / Gargantext / Database / Query / Table / Node.hs
index 7d1be5b4bc945643d24f241009c6021b3da363bf..34ffbb0a206cbf3dd4ed00378c383e16c41fcc7f 100644 (file)
@@ -9,7 +9,6 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
 {-# LANGUAGE Arrows                 #-}
@@ -27,7 +26,6 @@ import Control.Lens (set, view)
 import Data.Aeson
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import qualified Database.PostgreSQL.Simple as DPS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Opaleye hiding (FromField)
 import Prelude hiding (null, id, map, sum)
@@ -42,17 +40,19 @@ import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum, head)
 
+import qualified Database.PostgreSQL.Simple as PGS
+
 
-queryNodeSearchTable :: Query NodeSearchRead
+queryNodeSearchTable :: Select NodeSearchRead
 queryNodeSearchTable = selectTable nodeTableSearch
 
-selectNode :: Column PGInt4 -> Query NodeRead
+selectNode :: Column SqlInt4 -> Select NodeRead
 selectNode id' = proc () -> do
     row      <- queryNodeTable -< ()
     restrict -< _node_id row .== id'
     returnA  -< row
 
-runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
+runGetNodes :: Select NodeRead -> Cmd err [Node HyperdataAny]
 runGetNodes = runOpaQuery
 
 ------------------------------------------------------------------------
@@ -61,7 +61,7 @@ runGetNodes = runOpaQuery
 -- Favorites (Bool), node_ngrams
 selectNodesWith :: HasDBid NodeType
                 => ParentId     -> Maybe NodeType
-                -> Maybe Offset -> Maybe Limit   -> Query NodeRead
+                -> Maybe Offset -> Maybe Limit   -> Select NodeRead
 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
   limit' maybeLimit $ offset' maybeOffset
@@ -69,7 +69,7 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
                     $ selectNodesWith' parentId maybeNodeType
 
 selectNodesWith' :: HasDBid NodeType
-                 => ParentId -> Maybe NodeType -> Query NodeRead
+                 => ParentId -> Maybe NodeType -> Select NodeRead
 selectNodesWith' parentId maybeNodeType = proc () -> do
     node' <- (proc () -> do
       row@(Node _ _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
@@ -79,7 +79,7 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
 
       restrict -< if typeId' > 0
                      then typeId   .== (sqlInt4 (typeId' :: Int))
-                     else (pgBool True)
+                     else (sqlBool True)
       returnA  -< row ) -< ()
     returnA -< node'
 
@@ -125,7 +125,7 @@ getClosestParentIdByType :: HasDBid NodeType
                          -> NodeType
                          -> Cmd err (Maybe NodeId)
 getClosestParentIdByType nId nType = do
-  result <- runPGSQuery query (nId, 0 :: Int)
+  result <- runPGSQuery query (PGS.Only nId)
   case result of
     [(NodeId parentId, pTypename)] -> do
       if toDBid nType == pTypename then
@@ -134,12 +134,53 @@ getClosestParentIdByType nId nType = do
         getClosestParentIdByType (NodeId parentId) nType
     _ -> pure Nothing
   where
-    query :: DPS.Query
+    query :: PGS.Query
     query = [sql|
       SELECT n2.id, n2.typename
       FROM nodes n1
         JOIN nodes n2 ON n1.parent_id = n2.id
-        WHERE n1.id = ? AND 0 = ?;
+        WHERE n1.id = ?;
+    |]
+
+-- | Similar to `getClosestParentIdByType` but includes current node
+-- in search too
+getClosestParentIdByType' :: HasDBid NodeType
+                          => NodeId
+                          -> NodeType
+                          -> Cmd err (Maybe NodeId)
+getClosestParentIdByType' nId nType = do
+  result <- runPGSQuery query (PGS.Only nId)
+  case result of
+    [(NodeId id, pTypename)] -> do
+      if toDBid nType == pTypename then
+        pure $ Just $ NodeId id
+      else
+        getClosestParentIdByType nId nType
+    _ -> pure Nothing
+  where
+    query :: PGS.Query
+    query = [sql|
+      SELECT n.id, n.typename
+      FROM nodes n
+      WHERE n.id = ?;
+    |]
+
+-- | Given a node id, find all it's children (no matter how deep) of
+-- given node type.
+getChildrenByType :: HasDBid NodeType
+                  => NodeId
+                  -> NodeType
+                  -> Cmd err [NodeId]
+getChildrenByType nId nType = do
+  result <- runPGSQuery query (PGS.Only nId)
+  children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
+  pure $ concat $ [fst <$> filter (\(_, pTypename) -> pTypename == toDBid nType) result] ++ children_lst
+  where
+    query :: PGS.Query
+    query = [sql|
+      SELECT n.id, n.typename
+      FROM nodes n
+      WHERE n.parent_id = ?;
     |]
 
 ------------------------------------------------------------------------
@@ -157,7 +198,7 @@ getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataC
 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 
 ------------------------------------------------------------------------
-selectNodesWithParentID :: NodeId -> Query NodeRead
+selectNodesWithParentID :: NodeId -> Select NodeRead
 selectNodesWithParentID n = proc () -> do
     row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
     restrict -< parent_id .== (pgNodeId n)
@@ -171,7 +212,7 @@ getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType ->
 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
   where
     selectNodesWithType ::  HasDBid NodeType
-                         => NodeType -> Query NodeRead
+                         => NodeType -> Select NodeRead
     selectNodesWithType nt' = proc () -> do
         row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
         restrict -< tn .== (sqlInt4 $ toDBid nt')
@@ -183,7 +224,7 @@ getNodesIdWithType nt = do
   pure (map NodeId ns)
 
 selectNodesIdWithType :: HasDBid NodeType
-                      => NodeType -> Query (Column PGInt4)
+                      => NodeType -> Select (Column SqlInt4)
 selectNodesIdWithType nt = proc () -> do
     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
     restrict -< tn .== (sqlInt4 $ toDBid nt)
@@ -191,6 +232,9 @@ selectNodesIdWithType nt = proc () -> do
 
 ------------------------------------------------------------------------
 
+nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
+nodeExists nId = (== [PGS.Only True])
+  <$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? |] (PGS.Only nId)
 
 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 getNode nId = do
@@ -214,6 +258,14 @@ insertDefaultNode :: HasDBid NodeType
                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 
+insertDefaultNodeIfNotExists :: HasDBid NodeType
+                             => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
+insertDefaultNodeIfNotExists nt p u = do
+  children <- getChildrenByType p nt
+  case children of
+    [] -> insertDefaultNode nt p u
+    xs -> pure xs
+
 insertNode :: HasDBid NodeType
            => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
@@ -240,7 +292,7 @@ node nodeType name hyperData parentId userId =
        (pgNodeId <$> parentId)
        (sqlStrictText name)
        Nothing
-       (pgJSONB $ cs $ encode hyperData)
+       (sqlJSONB $ cs $ encode hyperData)
     where
       typeId = toDBid nodeType
 
@@ -281,7 +333,7 @@ insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> p
 
 node2table :: HasDBid NodeType
            => UserId -> Maybe ParentId -> Node' -> NodeWrite
-node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (sqlInt4 $ toDBid nt) (sqlInt4 uid) (fmap pgNodeId pid) (sqlStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
+node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (sqlInt4 $ toDBid nt) (sqlInt4 uid) (fmap pgNodeId pid) (sqlStrictText txt) Nothing (sqlStrictJSONB $ cs $ encode v)
 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 
 
@@ -345,7 +397,5 @@ defaultList cId =
 defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
 defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
 
-
 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
-