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