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