Remove superfluous gfortran extra-libraries stanza
[gargantext.git] / src / Gargantext / Database / Query / Table / Node.hs
index 9648ef8685041d18ad52f81abb961967a67426d1..4b8aec29e9b5ad1d98fab756a876c2adc3c9dd2b 100644 (file)
@@ -9,7 +9,7 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
 {-# LANGUAGE Arrows                 #-}
@@ -32,8 +32,8 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Opaleye hiding (FromField)
 import Prelude hiding (null, id, map, sum)
 
+import Gargantext.Core
 import Gargantext.Core.Types
-import Gargantext.Database.Admin.Config (nodeTypeId)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Hyperdata.Default
 import Gargantext.Database.Prelude
@@ -47,9 +47,9 @@ queryNodeSearchTable :: Query NodeSearchRead
 queryNodeSearchTable = queryTable nodeTableSearch
 
 selectNode :: Column PGInt4 -> Query NodeRead
-selectNode id = proc () -> do
+selectNode id' = proc () -> do
     row      <- queryNodeTable -< ()
-    restrict -< _node_id row .== id
+    restrict -< _node_id row .== id'
     returnA  -< row
 
 runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
@@ -59,7 +59,8 @@ runGetNodes = runOpaQuery
 ------------------------------------------------------------------------
 -- | order by publication date
 -- Favorites (Bool), node_ngrams
-selectNodesWith :: ParentId     -> Maybe NodeType
+selectNodesWith :: HasDBid NodeType
+                => ParentId     -> Maybe NodeType
                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
@@ -67,19 +68,20 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
                     $ orderBy (asc _node_id)
                     $ selectNodesWith' parentId maybeNodeType
 
-selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
+selectNodesWith' :: HasDBid NodeType
+                 => ParentId -> Maybe NodeType -> Query NodeRead
 selectNodesWith' parentId maybeNodeType = proc () -> do
-    node <- (proc () -> do
+    node' <- (proc () -> do
       row@(Node _ _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
       restrict -< parentId' .== (pgNodeId parentId)
 
-      let typeId' = maybe 0 nodeTypeId maybeNodeType
+      let typeId' = maybe 0 toDBid maybeNodeType
 
       restrict -< if typeId' > 0
                      then typeId   .== (pgInt4 (typeId' :: Int))
                      else (pgBool True)
       returnA  -< row ) -< ()
-    returnA -< node
+    returnA -< node'
 
 deleteNode :: NodeId -> Cmd err Int
 deleteNode n = mkCmd $ \conn ->
@@ -92,7 +94,7 @@ deleteNodes ns = mkCmd $ \conn ->
                    (\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 
 -- TODO: NodeType should match with `a'
-getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
+getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
@@ -112,14 +114,15 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 -- | Given a node id, find it's closest parent of given type
 -- NOTE: This isn't too optimal: can make successive queries depending on how
 -- deeply nested the child is.
-getClosestParentIdByType :: NodeId
+getClosestParentIdByType :: HasDBid NodeType
+                         => NodeId
                          -> NodeType
                          -> Cmd err (Maybe NodeId)
 getClosestParentIdByType nId nType = do
   result <- runPGSQuery query (nId, 0 :: Int)
   case result of
-    [DPS.Only parentId, DPS.Only pTypename] -> do
-      if nodeTypeId nType == pTypename then
+    [(NodeId parentId, pTypename)] -> do
+      if toDBid nType == pTypename then
         pure $ Just $ NodeId parentId
       else
         getClosestParentIdByType (NodeId parentId) nType
@@ -128,23 +131,23 @@ getClosestParentIdByType nId nType = do
     query :: DPS.Query
     query = [sql|
       SELECT n2.id, n2.typename
-        FROM nodes n1
+      FROM nodes n1
         JOIN nodes n2 ON n1.parent_id = n2.id
         WHERE n1.id = ? AND 0 = ?;
     |]
 
 ------------------------------------------------------------------------
-getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
+getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 
 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
-getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
+getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 
-getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataModel]
+getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 
-getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
+getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 
 ------------------------------------------------------------------------
@@ -158,24 +161,26 @@ selectNodesWithParentID n = proc () -> do
 ------------------------------------------------------------------------
 -- | Example of use:
 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
-getNodesWithType :: (HasNodeError err, JSONB a) => NodeType -> proxy a -> Cmd err [Node a]
+getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
   where
-    selectNodesWithType :: NodeType -> Query NodeRead
-    selectNodesWithType nt = proc () -> do
+    selectNodesWithType ::  HasDBid NodeType
+                         => NodeType -> Query NodeRead
+    selectNodesWithType nt' = proc () -> do
         row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
-        restrict -< tn .== (pgInt4 $ nodeTypeId nt)
+        restrict -< tn .== (pgInt4 $ toDBid nt')
         returnA -< row
 
-getNodesIdWithType :: HasNodeError err => NodeType -> Cmd err [NodeId]
+getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
 getNodesIdWithType nt = do
   ns <- runOpaQuery $ selectNodesIdWithType nt
   pure (map NodeId ns)
 
-selectNodesIdWithType :: NodeType -> Query (Column PGInt4)
+selectNodesIdWithType :: HasDBid NodeType
+                      => NodeType -> Query (Column PGInt4)
 selectNodesIdWithType nt = proc () -> do
     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
-    restrict -< tn .== (pgInt4 $ nodeTypeId nt)
+    restrict -< tn .== (pgInt4 $ toDBid nt)
     returnA -< _node_id row
 
 ------------------------------------------------------------------------
@@ -199,20 +204,23 @@ getNodeWith nId _ = do
 
 ------------------------------------------------------------------------
 -- | Sugar to insert Node with NodeType in Database
-insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
+insertDefaultNode :: HasDBid NodeType
+                  => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 
-insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
+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]
 
-nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
+nodeW ::  HasDBid NodeType
+       => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 nodeW nt n h p u = node nt n' h' (Just p) u
   where
     n' = fromMaybe (defaultName nt) n
     h' = maybe     (defaultHyperdata nt) identity h
 
 ------------------------------------------------------------------------
-node :: (ToJSON a, Hyperdata a)
+node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
      => NodeType
      -> Name
      -> a
@@ -228,7 +236,7 @@ node nodeType name hyperData parentId userId =
        Nothing
        (pgJSONB $ cs $ encode hyperData)
     where
-      typeId = nodeTypeId nodeType
+      typeId = toDBid nodeType
 
                   -------------------------------
 insertNodes :: [NodeWrite] -> Cmd err Int64
@@ -242,7 +250,7 @@ insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
     ns' :: [NodeWrite]
     ns' = map (\(Node i t u p n d h)
                 -> Node (pgNodeId          <$> i)
-                        (pgInt4 $ nodeTypeId   t)
+                        (pgInt4 $ toDBid      t)
                         (pgInt4                u)
                         (pgNodeId          <$> p)
                         (pgStrictText          n)
@@ -256,17 +264,18 @@ insertNodesR ns = mkCmd $ \conn ->
   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 
 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
-insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
+insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
 
 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
-insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
+insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
 ------------------------------------------------------------------------
 -- TODO
 -- currently this function removes the child relation
 -- needs a Temporary type between Node' and NodeWriteT
 
-node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
-node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
+node2table :: HasDBid NodeType
+           => UserId -> Maybe ParentId -> Node' -> NodeWrite
+node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (pgInt4 $ toDBid nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 
 
@@ -284,7 +293,8 @@ mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 
 ------------------------------------------------------------------------
-childWith :: UserId -> ParentId -> Node' -> NodeWrite
+childWith ::  HasDBid NodeType
+           => UserId -> ParentId -> Node' -> NodeWrite
 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
@@ -298,7 +308,7 @@ data CorpusType = CorpusDocument | CorpusContact
 
 class MkCorpus a
   where
-    mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
+    mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 
 instance MkCorpus HyperdataCorpus
   where
@@ -312,21 +322,21 @@ instance MkCorpus HyperdataAnnuaire
     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 
 
-getOrMkList :: HasNodeError err
+getOrMkList :: (HasNodeError err, HasDBid NodeType)
             => ParentId
             -> UserId
             -> Cmd err ListId
 getOrMkList pId uId =
   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
     where
-      mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
+      mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
 
 -- | TODO remove defaultList
-defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
+defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
 defaultList cId =
   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 
 
-getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
+getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)