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 {-# LANGUAGE Arrows #-}
  12
  13 module Gargantext.Database.Query.Tree.Root
  14   where
  15
  16 import Control.Arrow (returnA)
  17 import Data.Either (Either, fromLeft, fromRight)
  18 import Gargantext.Core
  19 import Gargantext.Core.Types.Individu (User(..))
  20 import Gargantext.Core.Types.Main (CorpusName)
  21 import Gargantext.Database.Action.Node
  22 import Gargantext.Database.Action.User (getUserId, getUsername)
  23 import Gargantext.Database.Admin.Config
  24 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
  25 import Gargantext.Database.Admin.Types.Node
  26 import Gargantext.Database.Prelude (Cmd, runOpaQuery)
  27 import Gargantext.Database.Query.Table.Node
  28 import Gargantext.Database.Query.Table.Node.Error
  29 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
  30 import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead)
  31 import Gargantext.Database.Schema.Node (queryNodeTable)
  32 import Gargantext.Prelude
  33 import Opaleye (restrict, (.==), Select)
  34 import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
  35
  36
  37 getRootId :: (HasNodeError err) => User -> Cmd err NodeId
  38 getRootId u = do
  39   maybeRoot <- head <$> getRoot u
  40   case maybeRoot of
  41     Nothing -> nodeError $ NodeError "[G.D.Q.T.R.getRootId] No root id"
  42     Just  r -> pure (_node_id r)
  43
  44 getRoot :: User -> Cmd err [Node HyperdataUser]
  45 getRoot = runOpaQuery . selectRoot
  46
  47 getOrMkRoot :: (HasNodeError err)
  48             => User
  49             -> Cmd err (UserId, RootId)
  50 getOrMkRoot user = do
  51   userId <- getUserId user
  52
  53   rootId' <- map _node_id <$> getRoot user
  54
  55   rootId'' <- case rootId' of
  56         []  -> mkRoot user
  57         n   -> case length n >= 2 of
  58             True  -> nodeError ManyNodeUsers
  59             False -> pure rootId'
  60
  61   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
  62   pure (userId, rootId)
  63
  64
  65 getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
  66                       => User
  67                       -> Either CorpusName [CorpusId]
  68                       -> Maybe a
  69                       -> Cmd err (UserId, RootId, CorpusId)
  70 getOrMk_RootWithCorpus user cName c = do
  71   (userId, rootId) <- getOrMkRoot user
  72   corpusId'' <- if user == UserName userMaster
  73                   then do
  74                     ns <- getCorporaWithParentId rootId
  75                     pure $ map _node_id ns
  76                   else
  77                     pure $ fromRight [] cName
  78
  79   corpusId' <- if corpusId'' /= []
  80                   then pure corpusId''
  81                   else do
  82                     c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
  83                     _tId <- case head c' of
  84                               Nothing  -> nodeError $ NodeError "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
  85                               Just c'' -> insertDefaultNode NodeTexts c'' userId
  86                     pure c'
  87
  88   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
  89   pure (userId, rootId, corpusId)
  90
  91
  92 mkRoot :: HasNodeError err
  93        => User
  94        -> Cmd err [RootId]
  95 mkRoot user = do
  96
  97   -- TODO
  98   -- udb <- getUserDb user
  99   -- let uid = user_id udb
 100   uid <- getUserId user
 101
 102   -- TODO ? Which name for user Node ?
 103   una <- getUsername user
 104
 105   case uid > 0 of
 106      False -> nodeError NegativeId
 107      True  -> do
 108        rs <- mkNodeWithParent NodeUser Nothing uid una
 109        _ <- case rs of
 110          [r] -> do
 111            _ <- insertNode NodeFolderPrivate Nothing Nothing r uid
 112            _ <- insertNode NodeFolderShared Nothing Nothing r uid
 113            _ <- insertNode NodeFolderPublic Nothing Nothing r uid
 114            pure rs
 115          _   -> pure rs
 116        pure rs
 117
 118 selectRoot :: User -> Select NodeRead
 119 selectRoot (UserName username) = proc () -> do
 120     row   <- queryNodeTable -< ()
 121     users <- queryUserTable -< ()
 122     restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
 123     restrict -< user_username  users .== (sqlStrictText username)
 124     restrict -< _node_user_id   row   .== (user_id users)
 125     returnA  -< row
 126
 127 selectRoot (UserDBId uid) = proc () -> do
 128     row   <- queryNodeTable -< ()
 129     restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
 130     restrict -< _node_user_id   row   .== (sqlInt4 uid)
 131     returnA  -< row
 132
 133 selectRoot (RootId nid) =
 134  proc () -> do
 135     row   <- queryNodeTable -< ()
 136     restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
 137     restrict -< _node_id   row   .== (pgNodeId nid)
 138     returnA  -< row
 139 selectRoot UserPublic = panic {-nodeError $ NodeError-}  "[G.D.Q.T.Root.selectRoot] No root for Public"