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   , updateUserEmail
  30   , updateUserPassword
  31   , updateUserForgotPasswordUUID
  32   , getUser
  33   , insertNewUsers
  34   , selectUsersLightWith
  35   , userWithUsername
  36   , userWithId
  37   , userLightWithId
  38   , getUsersWith
  39   , getUsersWithEmail
  40   , getUsersWithForgotPasswordUUID
  41   , getUsersWithId
  42   , module Gargantext.Database.Schema.User
  43   )
  44   where
  45
  46 import Control.Arrow (returnA)
  47 import Control.Lens ((^.))
  48 import Data.Maybe (fromMaybe)
  49 import Data.List (find)
  50 import Data.Text (Text)
  51 import Data.Time (UTCTime)
  52 import qualified Data.UUID as UUID
  53 import Gargantext.Core.Types.Individu
  54 import qualified Gargantext.Prelude.Crypto.Auth as Auth
  55 import Gargantext.Database.Admin.Config (nodeTypeId)
  56 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
  57 import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node)
  58 import Gargantext.Database.Prelude
  59 import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_user_id, node_typename)
  60 import Gargantext.Database.Schema.User
  61 import Gargantext.Prelude
  62 import Opaleye
  63
  64 ------------------------------------------------------------------------
  65 -- TODO: on conflict, nice message
  66 insertUsers :: [UserWrite] -> Cmd err Int64
  67 insertUsers us = mkCmd $ \c -> runInsert_ c insert
  68   where
  69     insert = Insert userTable us rCount Nothing
  70
  71 deleteUsers :: [Username] -> Cmd err Int64
  72 deleteUsers us = mkCmd $ \c -> runDelete_ c
  73                        $ Delete userTable
  74                                 (\user -> in_ (map sqlStrictText us) (user_username user))
  75                                 rCount
  76
  77 -- Updates email or password only (for now)
  78 updateUserDB :: UserWrite -> Cmd err Int64
  79 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
  80   where
  81     updateUserQuery :: UserWrite -> Update Int64
  82     updateUserQuery us' = Update
  83       { uTable      = userTable
  84       , uUpdateWith = updateEasy (\ (UserDB { .. })
  85                                   -> UserDB { user_password = p'
  86                                             , user_email = em'
  87                                             , .. }
  88                                  )
  89       , uWhere      = (\row -> user_username row .== un')
  90       , uReturning  = rCount
  91       }
  92         where
  93           UserDB { user_password = p'
  94                  , user_username = un'
  95                  , user_email = em' } = us'
  96
  97 -----------------------------------------------------------------------
  98 toUserWrite :: NewUser HashPassword -> UserWrite
  99 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
 100   UserDB { user_id = Nothing
 101          , user_password = sqlStrictText p
 102          , user_lastLogin = Nothing
 103          , user_isSuperUser = sqlBool True
 104          , user_username = sqlStrictText u
 105          , user_firstName = sqlStrictText "first_name"
 106          , user_lastName = sqlStrictText "last_name"
 107          , user_email = sqlStrictText m
 108          , user_isStaff = sqlBool True
 109          , user_isActive = sqlBool True
 110          , user_dateJoined = Nothing
 111          , user_forgot_password_uuid = Nothing }
 112
 113 ------------------------------------------------------------------
 114 getUsersWith :: Username -> Cmd err [UserLight]
 115 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
 116
 117 selectUsersLightWith :: Username -> Select UserRead
 118 selectUsersLightWith u = proc () -> do
 119       row      <- queryUserTable -< ()
 120       restrict -< user_username row .== sqlStrictText u
 121       returnA  -< row
 122
 123 getUsersWithEmail :: Text -> Cmd err [UserLight]
 124 getUsersWithEmail e = map toUserLight <$> runOpaQuery (selectUsersLightWithEmail e)
 125
 126 selectUsersLightWithEmail :: Text -> Select UserRead
 127 selectUsersLightWithEmail e = proc () -> do
 128       row      <- queryUserTable -< ()
 129       restrict -< user_email row .== sqlStrictText e
 130       returnA  -< row
 131
 132 getUsersWithForgotPasswordUUID :: UUID.UUID -> Cmd err [UserLight]
 133 getUsersWithForgotPasswordUUID uuid = map toUserLight <$> runOpaQuery (selectUsersLightWithForgotPasswordUUID uuid)
 134
 135 selectUsersLightWithForgotPasswordUUID :: UUID.UUID -> Select UserRead
 136 selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
 137       row      <- queryUserTable -< ()
 138       restrict -< user_forgot_password_uuid row .== sqlStrictText (UUID.toText uuid)
 139       returnA  -< row
 140
 141 ----------------------------------------------------------
 142 getUsersWithId :: Int -> Cmd err [UserLight]
 143 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
 144   where
 145     selectUsersLightWithId :: Int -> Select UserRead
 146     selectUsersLightWithId i' = proc () -> do
 147           row      <- queryUserTable -< ()
 148           restrict -< user_id row .== sqlInt4 i'
 149           returnA  -< row
 150
 151
 152 queryUserTable :: Select UserRead
 153 queryUserTable = selectTable userTable
 154
 155 ----------------------------------------------------------------------
 156 getUserHyperdata :: Int -> Cmd err [HyperdataUser]
 157 getUserHyperdata i = do
 158   runOpaQuery (selectUserHyperdataWithId i)
 159   where
 160     selectUserHyperdataWithId :: Int -> Select (Column SqlJsonb)
 161     selectUserHyperdataWithId i' = proc () -> do
 162       row      <- queryNodeTable -< ()
 163       restrict -< row^.node_user_id .== (sqlInt4 i')
 164       restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
 165       returnA  -< row^.node_hyperdata
 166
 167 getUserNodeHyperdata :: Int -> Cmd err [Node HyperdataUser]
 168 getUserNodeHyperdata i = do
 169   runOpaQuery (selectUserHyperdataWithId i)
 170   where
 171     selectUserHyperdataWithId :: Int -> Select NodeRead
 172     selectUserHyperdataWithId i' = proc () -> do
 173       row      <- queryNodeTable -< ()
 174       restrict -< row^.node_user_id .== (sqlInt4 i')
 175       restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
 176       returnA  -< row
 177
 178
 179
 180 getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
 181 getUsersWithHyperdata i = do
 182   u <- getUsersWithId i
 183   h <- getUserHyperdata i
 184   -- printDebug "[getUsersWithHyperdata]" (u,h)
 185   pure $ zip u h
 186
 187 getUsersWithNodeHyperdata :: Int -> Cmd err [(UserLight, Node HyperdataUser)]
 188 getUsersWithNodeHyperdata i = do
 189   u <- getUsersWithId i
 190   h <- getUserNodeHyperdata i
 191   -- printDebug "[getUsersWithHyperdata]" (u,h)
 192   pure $ zip u h
 193
 194
 195 updateUserEmail :: UserLight -> Cmd err Int64
 196 updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
 197   where
 198     updateUserQuery :: Update Int64
 199     updateUserQuery = Update
 200       { uTable      = userTable
 201       , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_email = sqlStrictText userLight_email, .. } )
 202       , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
 203       , uReturning  = rCount }
 204
 205 updateUserPassword :: UserLight -> Cmd err Int64
 206 updateUserPassword (UserLight { userLight_password = GargPassword password, .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
 207   where
 208     updateUserQuery :: Update Int64
 209     updateUserQuery = Update
 210       { uTable      = userTable
 211       , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_password = sqlStrictText password, .. } )
 212       , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
 213       , uReturning  = rCount }
 214
 215 updateUserForgotPasswordUUID :: UserLight -> Cmd err Int64
 216 updateUserForgotPasswordUUID (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
 217   where
 218     pass = sqlStrictText $ fromMaybe "" userLight_forgot_password_uuid
 219     updateUserQuery :: Update Int64
 220     updateUserQuery = Update
 221       { uTable      = userTable
 222       , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
 223       , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
 224       , uReturning  = rCount }
 225 ------------------------------------------------------------------
 226 -- | Select User with some parameters
 227 -- Not optimized version
 228 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 229 userWith f t xs = find (\x -> f x == t) xs
 230
 231 -- | Select User with Username
 232 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
 233 userWithUsername t xs = userWith user_username t xs
 234
 235 userWithId :: Int -> [UserDB] -> Maybe UserDB
 236 userWithId t xs = userWith user_id t xs
 237
 238 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 239 userLightWithUsername t xs = userWith userLight_username t xs
 240
 241 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 242 userLightWithId t xs = userWith userLight_id t xs
 243 ----------------------------------------------------------------------
 244 users :: Cmd err [UserDB]
 245 users = runOpaQuery queryUserTable
 246
 247 usersLight :: Cmd err [UserLight]
 248 usersLight = map toUserLight <$> users
 249
 250 getUser :: Username -> Cmd err (Maybe UserLight)
 251 getUser u = userLightWithUsername u <$> usersLight
 252
 253 ----------------------------------------------------------------------
 254 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
 255 insertNewUsers newUsers = do
 256   users' <- liftBase $ mapM toUserHash newUsers
 257   insertUsers $ map toUserWrite users'
 258
 259 ----------------------------------------------------------------------
 260 instance DefaultFromField SqlTimestamptz (Maybe UTCTime) where
 261   defaultFromField = fromPGSFromField