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