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