src/Gargantext/Database/Action/Share.hs

   1 {-|
   2 Module      : Gargantext.Database.Action.Share
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12
  13 {-# LANGUAGE Arrows                 #-}
  14
  15 module Gargantext.Database.Action.Share
  16   where
  17
  18 import Control.Arrow (returnA)
  19 import Control.Lens (view, (^.))
  20 import Data.Maybe (catMaybes)
  21 import Data.Text (Text)
  22 import Gargantext.Core.Types.Individu (User(..))
  23 import Gargantext.Database
  24 import Gargantext.Database.Action.User (getUserId)
  25 import Gargantext.Database.Admin.Config (hasNodeType, isInNodeTypes)
  26 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny(..))
  27 import Gargantext.Database.Admin.Types.Node
  28 -- import Gargantext.Database.Query.Join (leftJoin3')
  29 import Gargantext.Database.Query.Table.Node (getNode, getNodesWith)
  30 import Gargantext.Database.Query.Table.Node.Error (HasNodeError, errorWith)
  31 import Gargantext.Database.Query.Table.NodeNode (deleteNodeNode, queryNodeNodeTable)
  32 import Gargantext.Database.Query.Table.User
  33 import Gargantext.Database.Query.Tree.Root (getRootId)
  34 import Gargantext.Database.Schema.Node
  35 import Gargantext.Prelude
  36 import Gargantext.Utils.Tuple (uncurryMaybe)
  37 import Opaleye hiding (not)
  38 import qualified Opaleye as O
  39
  40 -- | TODO move in PhyloConfig of Gargantext
  41 publicNodeTypes :: [NodeType]
  42 publicNodeTypes = [NodeDashboard, NodeGraph, NodePhylo, NodeFile]
  43
  44 ------------------------------------------------------------------------
  45 data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
  46                                         , snwu_user     :: User
  47                                         }
  48                    | ShareNodeWith_Node { snwn_nodetype :: NodeType
  49                                         , snwn_node_id  :: NodeId
  50                                         }
  51 ------------------------------------------------------------------------
  52 deleteMemberShip :: HasNodeError err => [(SharedFolderId, TeamNodeId)] -> Cmd err [Int]
  53 deleteMemberShip xs = mapM (\(s,t) -> deleteNodeNode s t) xs
  54
  55 ------------------------------------------------------------------------
  56
  57 type SharedFolderId = NodeId
  58 type TeamNodeId     = NodeId
  59
  60 -- List members of a Team
  61 -- Result gives the username and its SharedFolderId that has to be eventually
  62 -- used for the membership
  63 membersOf :: HasNodeError err
  64           => TeamNodeId -> Cmd err [(Text, SharedFolderId)]
  65 membersOf nId = do
  66   res <- runOpaQuery $ membersOfQuery nId
  67   pure $ catMaybes (uncurryMaybe <$> res)
  68
  69
  70 membersOfQuery :: TeamNodeId
  71                -> SelectArr () (MaybeFields (Field SqlText), MaybeFields (Field SqlInt4))
  72 membersOfQuery (NodeId teamId) = proc () -> do
  73   (nn, n, u) <- nodeNode_node_User -< ()
  74   restrict -< (nn ^. nn_node2_id) .== sqlInt4 teamId
  75   returnA -< ( user_username <$> u
  76              , view node_id <$> n)
  77
  78
  79 nodeNode_node_User :: O.Select ( NodeNodeRead
  80                                , MaybeFields NodeRead
  81                                , MaybeFields UserRead )
  82 nodeNode_node_User = proc () -> do
  83   nn <- queryNodeNodeTable -< ()
  84   n <- optionalRestrict queryNodeTable -<
  85     \n' -> (n' ^. node_id) .== (nn ^. nn_node1_id)
  86   u <- optionalRestrict queryUserTable -<
  87     \u' -> (view node_user_id <$> n) .=== justFields (user_id u')
  88
  89   returnA -< (nn, n, u)
  90
  91 ------------------------------------------------------------------------
  92 -- To Share a Node Team with a user, use this function
  93 -- basically used with the invitation to a team
  94 shareNodeWith :: HasNodeError err
  95               => ShareNodeWith
  96               -> NodeId
  97               -> Cmd err Int
  98 shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
  99   nodeToCheck <- getNode   n
 100   userIdCheck <- getUserId u
 101   if not (hasNodeType nodeToCheck NodeTeam)
 102     then errorWith "[G.D.A.S.shareNodeWith] Can share node Team only"
 103     else
 104       if (view node_user_id nodeToCheck == userIdCheck)
 105         then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
 106         else do
 107           folderSharedId  <- getFolderId u NodeFolderShared
 108           insertDB ([NodeNode { _nn_node1_id = folderSharedId
 109                               , _nn_node2_id = n
 110                               , _nn_score = Nothing
 111                               , _nn_category = Nothing }]:: [NodeNode])
 112
 113 shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
 114   nodeToCheck <- getNode n
 115   if not (isInNodeTypes nodeToCheck publicNodeTypes)
 116     then errorWith $ "[G.D.A.S.shareNodeWith] Can share this nodesTypes only: "
 117                    <> (cs $ show publicNodeTypes)
 118     else do
 119       folderToCheck <- getNode nId
 120       if hasNodeType folderToCheck NodeFolderPublic
 121          then insertDB ([NodeNode { _nn_node1_id = nId
 122                                   , _nn_node2_id = n
 123                                   , _nn_score = Nothing
 124                                   , _nn_category = Nothing }] :: [NodeNode])
 125          else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
 126
 127 shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
 128
 129 ------------------------------------------------------------------------
 130 getFolderId :: HasNodeError err => User -> NodeType -> Cmd err NodeId
 131 getFolderId u nt = do
 132   rootId <- getRootId u
 133   s <- getNodesWith rootId HyperdataAny (Just nt) Nothing Nothing
 134   case head s of
 135     Nothing -> errorWith "[G.D.A.S.getFolderId] No folder shared found"
 136     Just  f -> pure (_node_id f)
 137
 138 ------------------------------------------------------------------------
 139 type TeamId = NodeId
 140
 141 delFolderTeam :: HasNodeError err => User -> TeamId -> Cmd err Int
 142 delFolderTeam u nId = do
 143   folderSharedId <- getFolderId u NodeFolderShared
 144   deleteNodeNode folderSharedId nId
 145
 146 unPublish :: HasNodeError err
 147           => ParentId -> NodeId
 148           -> Cmd err Int
 149 unPublish p n = deleteNodeNode p n