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