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