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
  58                        $ Delete userTable
  59                                 (\user -> in_ (map sqlStrictText us) (user_username user))
  60                                 rCount
  61
  62 -- Updates email or password only (for now)
  63 updateUserDB :: UserWrite -> Cmd err Int64
  64 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
  65   where
  66     updateUserQuery :: UserWrite -> Update Int64
  67     updateUserQuery us' = Update
  68       { uTable      = userTable
  69       , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
  70                                   -> UserDB _id p' ll su un fn ln em' is ia dj
  71                                  )
  72       , uWhere      = (\row -> user_username row .== un')
  73       , uReturning  = rCount
  74       }
  75         where
  76           UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
  77
  78 -----------------------------------------------------------------------
  79 toUserWrite :: NewUser HashPassword -> UserWrite
  80 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
  81   UserDB (Nothing) (sqlStrictText p)
  82          (Nothing) (pgBool True) (sqlStrictText u)
  83          (sqlStrictText "first_name")
  84          (sqlStrictText "last_name")
  85          (sqlStrictText m)
  86          (pgBool True)
  87          (pgBool True) Nothing
  88
  89 ------------------------------------------------------------------
  90 getUsersWith :: Username -> Cmd err [UserLight]
  91 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
  92
  93 selectUsersLightWith :: Username -> Query UserRead
  94 selectUsersLightWith u = proc () -> do
  95       row      <- queryUserTable -< ()
  96       restrict -< user_username row .== sqlStrictText u
  97       returnA  -< row
  98
  99 ----------------------------------------------------------
 100 getUsersWithId :: Int -> Cmd err [UserLight]
 101 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
 102   where
 103     selectUsersLightWithId :: Int -> Query UserRead
 104     selectUsersLightWithId i' = proc () -> do
 105           row      <- queryUserTable -< ()
 106           restrict -< user_id row .== sqlInt4 i'
 107           returnA  -< row
 108
 109
 110
 111 queryUserTable :: Query UserRead
 112 queryUserTable = selectTable userTable
 113
 114 ------------------------------------------------------------------
 115 -- | Select User with some parameters
 116 -- Not optimized version
 117 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 118 userWith f t xs = find (\x -> f x == t) xs
 119
 120 -- | Select User with Username
 121 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
 122 userWithUsername t xs = userWith user_username t xs
 123
 124 userWithId :: Int -> [UserDB] -> Maybe UserDB
 125 userWithId t xs = userWith user_id t xs
 126
 127 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 128 userLightWithUsername t xs = userWith userLight_username t xs
 129
 130 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 131 userLightWithId t xs = userWith userLight_id t xs
 132
 133 ----------------------------------------------------------------------
 134 users :: Cmd err [UserDB]
 135 users = runOpaQuery queryUserTable
 136
 137 usersLight :: Cmd err [UserLight]
 138 usersLight = map toUserLight <$> users
 139
 140 getUser :: Username -> Cmd err (Maybe UserLight)
 141 getUser u = userLightWithUsername u <$> usersLight
 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 DefaultFromField PGTimestamptz (Maybe UTCTime) where
 151   defaultFromField = fieldQueryRunnerColumn