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 Control.Arrow (returnA)
  23 import Data.Either (Either, fromLeft, fromRight)
  24 import Gargantext.Core.Types.Individu (User(..))
  25 import Gargantext.Core.Types.Main (CorpusName)
  26 import Gargantext.Database.Action.Node
  27 import Gargantext.Database.Action.User (getUserId, getUsername)
  28 import Gargantext.Database.Admin.Config (nodeTypeId, userMaster)
  29 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
  30 import Gargantext.Database.Admin.Types.Node
  31 import Gargantext.Database.Prelude (Cmd, runOpaQuery)
  32 import Gargantext.Database.Query.Table.Node
  33 import Gargantext.Database.Query.Table.Node.Error
  34 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
  35 import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead)
  36 import Gargantext.Database.Schema.Node (queryNodeTable)
  37 import Gargantext.Prelude
  38 import Opaleye (restrict, (.==), Query)
  39 import Opaleye.PGTypes (pgStrictText, pgInt4)
  40
  41
  42 getRootId :: (HasNodeError err) => User -> Cmd err NodeId
  43 getRootId u = do
  44   maybeRoot <- head <$> getRoot u
  45   case maybeRoot of
  46     Nothing -> nodeError $ NodeError "[G.D.Q.T.R.getRootId] No root id"
  47     Just  r -> pure (_node_id r)
  48
  49 getRoot :: User -> Cmd err [Node HyperdataUser]
  50 getRoot = runOpaQuery . selectRoot
  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  -> nodeError $ NodeError "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
  90                               Just c'' -> insertDefaultNode NodeTexts c'' userId
  91                     pure c'
  92
  93   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
  94   pure (userId, rootId, corpusId)
  95
  96
  97 mkRoot :: HasNodeError err
  98        => User
  99        -> Cmd err [RootId]
 100 mkRoot user = do
 101
 102   -- TODO
 103   -- udb <- getUserDb user
 104   -- let uid = user_id udb
 105   uid <- getUserId user
 106
 107   -- TODO ? Which name for user Node ?
 108   una <- getUsername user
 109
 110   case uid > 0 of
 111      False -> nodeError NegativeId
 112      True  -> do
 113        rs <- mkNodeWithParent NodeUser Nothing uid una
 114        _ <- case rs of
 115          [r] -> do
 116            _ <- insertNode NodeFolderPrivate Nothing Nothing r uid
 117            _ <- insertNode NodeFolderShared Nothing Nothing r uid
 118            _ <- insertNode NodeFolderPublic Nothing Nothing r uid
 119            pure rs
 120          _   -> pure rs
 121        pure rs
 122
 123 selectRoot :: User -> Query NodeRead
 124 selectRoot (UserName username) = proc () -> do
 125     row   <- queryNodeTable -< ()
 126     users <- queryUserTable -< ()
 127     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 128     restrict -< user_username  users .== (pgStrictText username)
 129     restrict -< _node_userId   row   .== (user_id users)
 130     returnA  -< row
 131
 132 selectRoot (UserDBId uid) = proc () -> do
 133     row   <- queryNodeTable -< ()
 134     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 135     restrict -< _node_userId   row   .== (pgInt4 uid)
 136     returnA  -< row
 137
 138 selectRoot (RootId nid) =
 139  proc () -> do
 140     row   <- queryNodeTable -< ()
 141     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 142     restrict -< _node_id   row   .== (pgNodeId nid)
 143     returnA  -< row
 144 selectRoot UserPublic = panic {-nodeError $ NodeError-}  "[G.D.Q.T.Root.selectRoot] No root for Public"