src/Gargantext/Database/Query/Tree/Root.hs

   1 {-|
   2 Module      : Gargantext.Database.Root
   3 Description : Main requests to get root of users
   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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 {-# LANGUAGE Arrows                 #-}
  15 {-# LANGUAGE DeriveGeneric          #-}
  16 {-# LANGUAGE ConstraintKinds        #-}
  17 {-# LANGUAGE FlexibleContexts       #-}
  18 {-# LANGUAGE FlexibleInstances      #-}
  19 {-# LANGUAGE FunctionalDependencies #-}
  20 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  21 {-# LANGUAGE OverloadedStrings #-}
  22 {-# LANGUAGE MultiParamTypeClasses  #-}
  23 {-# LANGUAGE NoImplicitPrelude      #-}
  24 {-# LANGUAGE RankNTypes             #-}
  25 {-# LANGUAGE TemplateHaskell        #-}
  26
  27 module Gargantext.Database.Query.Tree.Root
  28   where
  29
  30 import Data.Either (Either, fromLeft, fromRight)
  31 import Control.Arrow (returnA)
  32 import Gargantext.Core.Types.Main (CorpusName)
  33 import Gargantext.Core.Types.Individu (User(..))
  34 import Gargantext.Database.Admin.Config (nodeTypeId, userMaster)
  35 import Gargantext.Database.Admin.Types.Errors
  36 import Gargantext.Database.Admin.Types.Node
  37 import Gargantext.Database.Query.Table.Node
  38 import Gargantext.Database.Query.Table.Node.User (HyperdataUser)
  39 import Gargantext.Database.Action.Flow.Utils (getUserId)
  40 import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead)
  41 import Gargantext.Database.Schema.Node (queryNodeTable)
  42 import Gargantext.Database.Query
  43 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
  44 import Gargantext.Database.Admin.Types.Node (Node, NodeType(NodeUser), pgNodeId)
  45 import Gargantext.Database.Admin.Utils (Cmd, runOpaQuery)
  46 import Gargantext.Prelude
  47 import Opaleye (restrict, (.==), Query)
  48 import Opaleye.PGTypes (pgStrictText, pgInt4)
  49
  50
  51
  52 getOrMkRoot :: (HasNodeError err)
  53             => User
  54             -> Cmd err (UserId, RootId)
  55 getOrMkRoot user = do
  56   userId <- getUserId user
  57
  58   rootId' <- map _node_id <$> getRoot user
  59
  60   rootId'' <- case rootId' of
  61         []  -> mkRoot user
  62         n   -> case length n >= 2 of
  63             True  -> nodeError ManyNodeUsers
  64             False -> pure rootId'
  65
  66   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
  67   pure (userId, rootId)
  68
  69
  70 getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
  71                       => User
  72                       -> Either CorpusName [CorpusId]
  73                       -> Maybe a
  74                       -> Cmd err (UserId, RootId, CorpusId)
  75 getOrMk_RootWithCorpus user cName c = do
  76   (userId, rootId) <- getOrMkRoot user
  77   corpusId'' <- if user == UserName userMaster
  78                   then do
  79                     ns <- getCorporaWithParentId rootId
  80                     pure $ map _node_id ns
  81                   else
  82                     pure $ fromRight [] cName
  83
  84   corpusId' <- if corpusId'' /= []
  85                   then pure corpusId''
  86                   else do
  87                     c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
  88                     _tId <- case head c' of
  89                               Nothing -> pure [0]
  90                               Just c'' -> mkNode NodeTexts c'' userId
  91                     pure c'
  92
  93   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
  94   pure (userId, rootId, corpusId)
  95
  96
  97
  98
  99
 100
 101 mkRoot :: HasNodeError err
 102        => User
 103        -> Cmd err [RootId]
 104 mkRoot user = do
 105
 106   -- TODO
 107   -- udb <- getUserDb user
 108   -- let uid = user_id udb
 109   uid <- getUserId user
 110
 111   -- TODO ? Which name for user Node ?
 112   let una = "username"
 113
 114   case uid > 0 of
 115      False -> nodeError NegativeId
 116      True  -> do
 117        rs <- mkNodeWithParent NodeUser Nothing uid una
 118        _ <- case rs of
 119          [r] -> do
 120            _ <- mkNodeWithParent NodeFolderPrivate (Just r) uid una
 121            _ <- mkNodeWithParent NodeFolderShared  (Just r) uid una
 122            _ <- mkNodeWithParent NodeFolderPublic  (Just r) uid una
 123            pure rs
 124          _   -> pure rs
 125        pure rs
 126
 127 getRoot :: User -> Cmd err [Node HyperdataUser]
 128 getRoot = runOpaQuery . selectRoot
 129
 130 selectRoot :: User -> Query NodeRead
 131 selectRoot (UserName username) = proc () -> do
 132     row   <- queryNodeTable -< ()
 133     users <- queryUserTable -< ()
 134     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 135     restrict -< user_username  users .== (pgStrictText username)
 136     restrict -< _node_userId   row   .== (user_id users)
 137     returnA  -< row
 138
 139 selectRoot (UserDBId uid) = proc () -> do
 140     row   <- queryNodeTable -< ()
 141     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 142     restrict -< _node_userId   row   .== (pgInt4 uid)
 143     returnA  -< row
 144
 145 selectRoot (RootId nid) =
 146  proc () -> do
 147     row   <- queryNodeTable -< ()
 148     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 149     restrict -< _node_id   row   .== (pgNodeId nid)
 150     returnA  -< row
 151