src/Gargantext/Database/Query/Table/User.hs

   1 {-|
   2 Module      : Gargantext.Database.Query.Table.User
   3 Description : User Database management tools
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Functions to deal with users, database side.
  11 -}
  12
  13
  14 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  15
  16 {-# LANGUAGE TemplateHaskell             #-}
  17 {-# LANGUAGE FunctionalDependencies      #-}
  18 {-# LANGUAGE Arrows                      #-}
  19
  20 module Gargantext.Database.Query.Table.User
  21   ( insertUsers
  22   , toUserWrite
  23   , deleteUsers
  24   , updateUserDB
  25   , queryUserTable
  26   , getUserHyperdata
  27   , getUsersWithHyperdata
  28   , getUsersWithNodeHyperdata
  29   , getUser
  30   , insertNewUsers
  31   , selectUsersLightWith
  32   , userWithUsername
  33   , userWithId
  34   , userLightWithId
  35   , getUsersWith
  36   , getUsersWithId
  37   , module Gargantext.Database.Schema.User
  38   )
  39   where
  40
  41 import Control.Arrow (returnA)
  42 import Control.Lens ((^.))
  43 import Data.List (find)
  44 import Data.Text (Text)
  45 import Data.Time (UTCTime)
  46 import Gargantext.Core.Types.Individu
  47 import qualified Gargantext.Prelude.Crypto.Auth as Auth
  48 import Gargantext.Database.Admin.Config (nodeTypeId)
  49 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
  50 import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node)
  51 import Gargantext.Database.Prelude
  52 import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_user_id, node_typename)
  53 import Gargantext.Database.Schema.User
  54 import Gargantext.Prelude
  55 import Opaleye
  56
  57 ------------------------------------------------------------------------
  58 -- TODO: on conflict, nice message
  59 insertUsers :: [UserWrite] -> Cmd err Int64
  60 insertUsers us = mkCmd $ \c -> runInsert_ c insert
  61   where
  62     insert = Insert userTable us rCount Nothing
  63
  64 deleteUsers :: [Username] -> Cmd err Int64
  65 deleteUsers us = mkCmd $ \c -> runDelete_ c
  66                        $ Delete userTable
  67                                 (\user -> in_ (map sqlStrictText us) (user_username user))
  68                                 rCount
  69
  70 -- Updates email or password only (for now)
  71 updateUserDB :: UserWrite -> Cmd err Int64
  72 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
  73   where
  74     updateUserQuery :: UserWrite -> Update Int64
  75     updateUserQuery us' = Update
  76       { uTable      = userTable
  77       , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
  78                                   -> UserDB _id p' ll su un fn ln em' is ia dj
  79                                  )
  80       , uWhere      = (\row -> user_username row .== un')
  81       , uReturning  = rCount
  82       }
  83         where
  84           UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
  85
  86 -----------------------------------------------------------------------
  87 toUserWrite :: NewUser HashPassword -> UserWrite
  88 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
  89   UserDB (Nothing) (sqlStrictText p)
  90          (Nothing) (sqlBool True) (sqlStrictText u)
  91          (sqlStrictText "first_name")
  92          (sqlStrictText "last_name")
  93          (sqlStrictText m)
  94          (sqlBool True)
  95          (sqlBool True) Nothing
  96
  97 ------------------------------------------------------------------
  98 getUsersWith :: Username -> Cmd err [UserLight]
  99 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
 100
 101 selectUsersLightWith :: Username -> Select UserRead
 102 selectUsersLightWith u = proc () -> do
 103       row      <- queryUserTable -< ()
 104       restrict -< user_username row .== sqlStrictText u
 105       returnA  -< row
 106
 107 ----------------------------------------------------------
 108 getUsersWithId :: Int -> Cmd err [UserLight]
 109 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
 110   where
 111     selectUsersLightWithId :: Int -> Select UserRead
 112     selectUsersLightWithId i' = proc () -> do
 113           row      <- queryUserTable -< ()
 114           restrict -< user_id row .== sqlInt4 i'
 115           returnA  -< row
 116
 117
 118 queryUserTable :: Select UserRead
 119 queryUserTable = selectTable userTable
 120
 121 ----------------------------------------------------------------------
 122 getUserHyperdata :: Int -> Cmd err [HyperdataUser]
 123 getUserHyperdata i = do
 124   runOpaQuery (selectUserHyperdataWithId i)
 125   where
 126     selectUserHyperdataWithId :: Int -> Select (Column SqlJsonb)
 127     selectUserHyperdataWithId i' = proc () -> do
 128       row      <- queryNodeTable -< ()
 129       restrict -< row^.node_user_id .== (sqlInt4 i')
 130       restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
 131       returnA  -< row^.node_hyperdata
 132
 133 getUserNodeHyperdata :: Int -> Cmd err [Node HyperdataUser]
 134 getUserNodeHyperdata i = do
 135   runOpaQuery (selectUserHyperdataWithId i)
 136   where
 137     selectUserHyperdataWithId :: Int -> Select NodeRead
 138     selectUserHyperdataWithId i' = proc () -> do
 139       row      <- queryNodeTable -< ()
 140       restrict -< row^.node_user_id .== (sqlInt4 i')
 141       restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
 142       returnA  -< row
 143
 144
 145
 146 getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
 147 getUsersWithHyperdata i = do
 148   u <- getUsersWithId i
 149   h <- getUserHyperdata i
 150   -- printDebug "[getUsersWithHyperdata]" (u,h)
 151   pure $ zip u h
 152
 153 getUsersWithNodeHyperdata :: Int -> Cmd err [(UserLight, Node HyperdataUser)]
 154 getUsersWithNodeHyperdata i = do
 155   u <- getUsersWithId i
 156   h <- getUserNodeHyperdata i
 157   -- printDebug "[getUsersWithHyperdata]" (u,h)
 158   pure $ zip u h
 159
 160
 161
 162 ------------------------------------------------------------------
 163 -- | Select User with some parameters
 164 -- Not optimized version
 165 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 166 userWith f t xs = find (\x -> f x == t) xs
 167
 168 -- | Select User with Username
 169 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
 170 userWithUsername t xs = userWith user_username t xs
 171
 172 userWithId :: Int -> [UserDB] -> Maybe UserDB
 173 userWithId t xs = userWith user_id t xs
 174
 175 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 176 userLightWithUsername t xs = userWith userLight_username t xs
 177
 178 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 179 userLightWithId t xs = userWith userLight_id t xs
 180 ----------------------------------------------------------------------
 181 users :: Cmd err [UserDB]
 182 users = runOpaQuery queryUserTable
 183
 184 usersLight :: Cmd err [UserLight]
 185 usersLight = map toUserLight <$> users
 186
 187 getUser :: Username -> Cmd err (Maybe UserLight)
 188 getUser u = userLightWithUsername u <$> usersLight
 189
 190 ----------------------------------------------------------------------
 191 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
 192 insertNewUsers newUsers = do
 193   users' <- liftBase $ mapM toUserHash newUsers
 194   insertUsers $ map toUserWrite users'
 195
 196 ----------------------------------------------------------------------
 197 instance DefaultFromField SqlTimestamptz (Maybe UTCTime) where
 198   defaultFromField = fromPGSFromField