Portability : POSIX
-}
-
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
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)
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
------------------------------------------------------------------------
-- 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
$ 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 -< ()
restrict -< if typeId' > 0
then typeId .== (sqlInt4 (typeId' :: Int))
- else (pgBool True)
+ else (sqlBool True)
returnA -< row ) -< ()
returnA -< node'
-> 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
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 = ?;
|]
------------------------------------------------------------------------
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)
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')
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)
------------------------------------------------------------------------
+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
=> 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]
(pgNodeId <$> parentId)
(sqlStrictText name)
Nothing
- (pgJSONB $ cs $ encode hyperData)
+ (sqlJSONB $ cs $ encode hyperData)
where
typeId = toDBid nodeType
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"
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)
-