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   , getUser
  28   , insertNewUsers
  29   , selectUsersLightWith
  30   , userWithUsername
  31   , userWithId
  32   , userLightWithId
  33   , getUsersWith
  34   , getUsersWithId
  35   , module Gargantext.Database.Schema.User
  36   )
  37   where
  38
  39 import Control.Arrow (returnA)
  40 import Control.Lens ((^.))
  41 import Data.List (find)
  42 import Data.Text (Text)
  43 import Data.Time (UTCTime)
  44 import Gargantext.Core.Types.Individu
  45 import qualified Gargantext.Prelude.Crypto.Auth as Auth
  46 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
  47 import Gargantext.Database.Prelude
  48 import Gargantext.Database.Schema.Node (node_hyperdata, node_id, queryNodeTable)
  49 import Gargantext.Database.Schema.User
  50 import Gargantext.Prelude
  51 import Opaleye
  52
  53 ------------------------------------------------------------------------
  54 -- TODO: on conflict, nice message
  55 insertUsers :: [UserWrite] -> Cmd err Int64
  56 insertUsers us = mkCmd $ \c -> runInsert_ c insert
  57   where
  58     insert = Insert userTable us rCount Nothing
  59
  60 deleteUsers :: [Username] -> Cmd err Int64
  61 deleteUsers us = mkCmd $ \c -> runDelete_ c
  62                        $ Delete userTable
  63                                 (\user -> in_ (map sqlStrictText us) (user_username user))
  64                                 rCount
  65
  66 -- Updates email or password only (for now)
  67 updateUserDB :: UserWrite -> Cmd err Int64
  68 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
  69   where
  70     updateUserQuery :: UserWrite -> Update Int64
  71     updateUserQuery us' = Update
  72       { uTable      = userTable
  73       , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
  74                                   -> UserDB _id p' ll su un fn ln em' is ia dj
  75                                  )
  76       , uWhere      = (\row -> user_username row .== un')
  77       , uReturning  = rCount
  78       }
  79         where
  80           UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
  81
  82 -----------------------------------------------------------------------
  83 toUserWrite :: NewUser HashPassword -> UserWrite
  84 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
  85   UserDB (Nothing) (sqlStrictText p)
  86          (Nothing) (pgBool True) (sqlStrictText u)
  87          (sqlStrictText "first_name")
  88          (sqlStrictText "last_name")
  89          (sqlStrictText m)
  90          (pgBool True)
  91          (pgBool True) Nothing
  92
  93 ------------------------------------------------------------------
  94 getUsersWith :: Username -> Cmd err [UserLight]
  95 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
  96
  97 selectUsersLightWith :: Username -> Query UserRead
  98 selectUsersLightWith u = proc () -> do
  99       row      <- queryUserTable -< ()
 100       restrict -< user_username row .== sqlStrictText u
 101       returnA  -< row
 102
 103 ----------------------------------------------------------
 104 getUsersWithId :: Int -> Cmd err [UserLight]
 105 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
 106   where
 107     selectUsersLightWithId :: Int -> Query UserRead
 108     selectUsersLightWithId i' = proc () -> do
 109           row      <- queryUserTable -< ()
 110           restrict -< user_id row .== sqlInt4 i'
 111           returnA  -< row
 112
 113
 114 queryUserTable :: Query UserRead
 115 queryUserTable = selectTable userTable
 116
 117 ----------------------------------------------------------------------
 118 getUserHyperdata :: Int -> Cmd err [HyperdataUser]
 119 getUserHyperdata i = do
 120   runOpaQuery (selectUserHyperdataWithId i)
 121   where
 122     selectUserHyperdataWithId :: Int -> Query (Column PGJsonb)
 123     selectUserHyperdataWithId i' = proc () -> do
 124       row      <- queryNodeTable -< ()
 125       restrict -< row^.node_id .== (sqlInt4 i')
 126       returnA  -< row^.node_hyperdata
 127 ------------------------------------------------------------------
 128 -- | Select User with some parameters
 129 -- Not optimized version
 130 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 131 userWith f t xs = find (\x -> f x == t) xs
 132
 133 -- | Select User with Username
 134 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
 135 userWithUsername t xs = userWith user_username t xs
 136
 137 userWithId :: Int -> [UserDB] -> Maybe UserDB
 138 userWithId t xs = userWith user_id t xs
 139
 140 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 141 userLightWithUsername t xs = userWith userLight_username t xs
 142
 143 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 144 userLightWithId t xs = userWith userLight_id t xs
 145 ----------------------------------------------------------------------
 146 users :: Cmd err [UserDB]
 147 users = runOpaQuery queryUserTable
 148
 149 usersLight :: Cmd err [UserLight]
 150 usersLight = map toUserLight <$> users
 151
 152 getUser :: Username -> Cmd err (Maybe UserLight)
 153 getUser u = userLightWithUsername u <$> usersLight
 154
 155 ----------------------------------------------------------------------
 156 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
 157 insertNewUsers newUsers = do
 158   users' <- liftBase $ mapM toUserHash newUsers
 159   insertUsers $ map toUserWrite users'
 160
 161 ----------------------------------------------------------------------
 162 instance DefaultFromField PGTimestamptz (Maybe UTCTime) where
 163   defaultFromField = fieldQueryRunnerColumn