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 Arrows                      #-}
  17 {-# LANGUAGE FunctionalDependencies      #-}
  18 {-# LANGUAGE QuasiQuotes            #-}
  19 {-# LANGUAGE TemplateHaskell             #-}
  20
  21 module Gargantext.Database.Query.Table.User
  22   ( insertUsers
  23   , toUserWrite
  24   , deleteUsers
  25   , updateUserDB
  26   , queryUserTable
  27   , getUserHyperdata
  28   , getUsersWithHyperdata
  29   , getUsersWithNodeHyperdata
  30   , updateUserEmail
  31   , updateUserPassword
  32   , updateUserForgotPasswordUUID
  33   , getUserPubmedAPIKey
  34   , updateUserPubmedAPIKey
  35   , getUser
  36   , insertNewUsers
  37   , selectUsersLightWith
  38   , userWithUsername
  39   , userWithId
  40   , userLightWithId
  41   , getUsersWith
  42   , getUsersWithEmail
  43   , getUsersWithForgotPasswordUUID
  44   , getUsersWithId
  45   , module Gargantext.Database.Schema.User
  46   )
  47   where
  48
  49 import Control.Arrow (returnA)
  50 import Control.Lens ((^.), (?~))
  51 import Data.List (find)
  52 import Data.Maybe (fromMaybe)
  53 import Data.Proxy
  54 import Data.Text (Text)
  55 import Data.Time (UTCTime)
  56 import qualified Data.UUID as UUID
  57 import Gargantext.Core.Types.Individu
  58 import qualified Gargantext.Prelude.Crypto.Auth as Auth
  59 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key)
  60 import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node, NodeId(..), pgNodeId)
  61 import Gargantext.Database.Prelude
  62 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateNodeWithType)
  63 import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_id, node_user_id, node_typename)
  64 import Gargantext.Database.Schema.User
  65 import Gargantext.Prelude
  66 import Opaleye
  67 import qualified PUBMED.Types as PUBMED
  68 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  69 import Gargantext.Core (HasDBid)
  70 import Gargantext.Database.Admin.Config (nodeTypeId)
  71
  72 ------------------------------------------------------------------------
  73 -- TODO: on conflict, nice message
  74 insertUsers :: [UserWrite] -> Cmd err Int64
  75 insertUsers us = mkCmd $ \c -> runInsert_ c insert
  76   where
  77     insert = Insert userTable us rCount Nothing
  78
  79 deleteUsers :: [Username] -> Cmd err Int64
  80 deleteUsers us = mkCmd $ \c -> runDelete_ c
  81                        $ Delete userTable
  82                                 (\user -> in_ (map sqlStrictText us) (user_username user))
  83                                 rCount
  84
  85 -- Updates email or password only (for now)
  86 updateUserDB :: UserWrite -> Cmd err Int64
  87 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
  88   where
  89     updateUserQuery :: UserWrite -> Update Int64
  90     updateUserQuery us' = Update
  91       { uTable      = userTable
  92       , uUpdateWith = updateEasy (\ (UserDB { .. })
  93                                   -> UserDB { user_password = p'
  94                                             , user_email = em'
  95                                             , .. }
  96                                  )
  97       , uWhere      = \row -> user_username row .== un'
  98       , uReturning  = rCount
  99       }
 100         where
 101           UserDB { user_password = p'
 102                  , user_username = un'
 103                  , user_email = em' } = us'
 104
 105 -----------------------------------------------------------------------
 106 toUserWrite :: NewUser HashPassword -> UserWrite
 107 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
 108   UserDB { user_id = Nothing
 109          , user_password = sqlStrictText p
 110          , user_lastLogin = Nothing
 111          , user_isSuperUser = sqlBool True
 112          , user_username = sqlStrictText u
 113          , user_firstName = sqlStrictText "first_name"
 114          , user_lastName = sqlStrictText "last_name"
 115          , user_email = sqlStrictText m
 116          , user_isStaff = sqlBool True
 117          , user_isActive = sqlBool True
 118          , user_dateJoined = Nothing
 119          , user_forgot_password_uuid = Nothing }
 120
 121 ------------------------------------------------------------------
 122 getUsersWith :: Username -> Cmd err [UserLight]
 123 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
 124
 125 selectUsersLightWith :: Username -> Select UserRead
 126 selectUsersLightWith u = proc () -> do
 127       row      <- queryUserTable -< ()
 128       restrict -< user_username row .== sqlStrictText u
 129       returnA  -< row
 130
 131 getUsersWithEmail :: Text -> Cmd err [UserLight]
 132 getUsersWithEmail e = map toUserLight <$> runOpaQuery (selectUsersLightWithEmail e)
 133
 134 selectUsersLightWithEmail :: Text -> Select UserRead
 135 selectUsersLightWithEmail e = proc () -> do
 136       row      <- queryUserTable -< ()
 137       restrict -< user_email row .== sqlStrictText e
 138       returnA  -< row
 139
 140 getUsersWithForgotPasswordUUID :: UUID.UUID -> Cmd err [UserLight]
 141 getUsersWithForgotPasswordUUID uuid = map toUserLight <$> runOpaQuery (selectUsersLightWithForgotPasswordUUID uuid)
 142
 143 selectUsersLightWithForgotPasswordUUID :: UUID.UUID -> Select UserRead
 144 selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
 145       row      <- queryUserTable -< ()
 146       restrict -< user_forgot_password_uuid row .== sqlStrictText (UUID.toText uuid)
 147       returnA  -< row
 148
 149 ----------------------------------------------------------
 150 getUsersWithId :: User -> Cmd err [UserLight]
 151 getUsersWithId (UserDBId i) = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
 152   where
 153     selectUsersLightWithId :: Int -> Select UserRead
 154     selectUsersLightWithId i' = proc () -> do
 155       row      <- queryUserTable -< ()
 156       restrict -< user_id row .== sqlInt4 i'
 157       returnA  -< row
 158 getUsersWithId (RootId i) = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
 159   where
 160     selectUsersLightWithId :: NodeId -> Select UserRead
 161     selectUsersLightWithId i' = proc () -> do
 162       n <- queryNodeTable -< ()
 163       restrict -< n^.node_id .== pgNodeId i'
 164       restrict -< n^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
 165       row      <- queryUserTable -< ()
 166       restrict -< user_id row .== n^.node_user_id
 167       returnA  -< row
 168 getUsersWithId _ = undefined
 169
 170
 171 queryUserTable :: Select UserRead
 172 queryUserTable = selectTable userTable
 173
 174 ----------------------------------------------------------------------
 175 -- | Get hyperdata associated with user node.
 176 getUserHyperdata :: User -> Cmd err [HyperdataUser]
 177 getUserHyperdata (RootId uId) = do
 178   runOpaQuery (selectUserHyperdataWithId uId)
 179   where
 180     selectUserHyperdataWithId :: NodeId -> Select (Field SqlJsonb)
 181     selectUserHyperdataWithId i' = proc () -> do
 182       row      <- queryNodeTable -< ()
 183       restrict -< row^.node_id .== pgNodeId i'
 184       returnA  -< row^.node_hyperdata
 185 getUserHyperdata (UserDBId uId) = do
 186   runOpaQuery (selectUserHyperdataWithId uId)
 187   where
 188     selectUserHyperdataWithId :: Int -> Select (Field SqlJsonb)
 189     selectUserHyperdataWithId i' = proc () -> do
 190       row      <- queryNodeTable -< ()
 191       restrict -< row^.node_user_id .== sqlInt4 i'
 192       restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
 193       returnA  -< row^.node_hyperdata
 194 getUserHyperdata _ = undefined
 195
 196
 197 -- | Same as `getUserHyperdata` but returns a `Node` type.
 198 getUserNodeHyperdata :: User -> Cmd err [Node HyperdataUser]
 199 getUserNodeHyperdata (RootId uId) = do
 200   runOpaQuery (selectUserHyperdataWithId uId)
 201   where
 202     selectUserHyperdataWithId :: NodeId -> Select NodeRead
 203     selectUserHyperdataWithId i' = proc () -> do
 204       row      <- queryNodeTable -< ()
 205       restrict -< row^.node_id .== pgNodeId i'
 206       returnA  -< row
 207 getUserNodeHyperdata (UserDBId uId) = do
 208   runOpaQuery (selectUserHyperdataWithId uId)
 209   where
 210     selectUserHyperdataWithId :: Int -> Select NodeRead
 211     selectUserHyperdataWithId i' = proc () -> do
 212       row      <- queryNodeTable -< ()
 213       restrict -< row^.node_user_id .== sqlInt4 i'
 214       restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
 215       returnA  -< row
 216 getUserNodeHyperdata _ = undefined
 217
 218 getUsersWithHyperdata :: User -> Cmd err [(UserLight, HyperdataUser)]
 219 getUsersWithHyperdata i = do
 220   u <- getUsersWithId i
 221   h <- getUserHyperdata i
 222   -- printDebug "[getUsersWithHyperdata]" (u,h)
 223   pure $ zip u h
 224
 225 getUsersWithNodeHyperdata :: User -> Cmd err [(UserLight, Node HyperdataUser)]
 226 getUsersWithNodeHyperdata i = do
 227   u <- getUsersWithId i
 228   h <- getUserNodeHyperdata i
 229   -- printDebug "[getUsersWithHyperdata]" (u,h)
 230   pure $ zip u h
 231
 232
 233 updateUserEmail :: UserLight -> Cmd err Int64
 234 updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
 235   where
 236     updateUserQuery :: Update Int64
 237     updateUserQuery = Update
 238       { uTable      = userTable
 239       , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_email = sqlStrictText userLight_email, .. } )
 240       , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
 241       , uReturning  = rCount }
 242
 243 updateUserPassword :: UserLight -> Cmd err Int64
 244 updateUserPassword (UserLight { userLight_password = GargPassword password, .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
 245   where
 246     updateUserQuery :: Update Int64
 247     updateUserQuery = Update
 248       { uTable      = userTable
 249       , uUpdateWith = updateEasy (\(UserDB { .. }) -> UserDB { user_password = sqlStrictText password, .. } )
 250       , uWhere      = \row -> user_id row .== sqlInt4 userLight_id
 251       , uReturning  = rCount }
 252
 253 updateUserForgotPasswordUUID :: UserLight -> Cmd err Int64
 254 updateUserForgotPasswordUUID (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
 255   where
 256     pass = sqlStrictText $ fromMaybe "" userLight_forgot_password_uuid
 257     updateUserQuery :: Update Int64
 258     updateUserQuery = Update
 259       { uTable      = userTable
 260       , uUpdateWith = updateEasy (\(UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
 261       , uWhere      = \row -> user_id row .== sqlInt4 userLight_id
 262       , uReturning  = rCount }
 263
 264 getUserPubmedAPIKey :: User -> Cmd err (Maybe PUBMED.APIKey)
 265 getUserPubmedAPIKey user = do
 266   hs <- getUserHyperdata user
 267   case hs of
 268     [] -> pure Nothing
 269     (x:_) -> pure $ _hu_pubmed_api_key x
 270
 271 updateUserPubmedAPIKey :: (HasDBid NodeType, HasNodeError err)
 272                         => User -> PUBMED.APIKey -> Cmd err Int64
 273 updateUserPubmedAPIKey (RootId uId) apiKey = do
 274   _ <- updateNodeWithType uId NodeUser (Proxy :: Proxy HyperdataUser) (\h -> h & hu_pubmed_api_key ?~ apiKey)
 275   pure 1
 276 updateUserPubmedAPIKey _ _ = undefined
 277 ------------------------------------------------------------------
 278 -- | Select User with some parameters
 279 -- Not optimized version
 280 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 281 userWith f t xs = find (\x -> f x == t) xs
 282
 283 -- | Select User with Username
 284 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
 285 userWithUsername t xs = userWith user_username t xs
 286
 287 userWithId :: Int -> [UserDB] -> Maybe UserDB
 288 userWithId t xs = userWith user_id t xs
 289
 290 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 291 userLightWithUsername t xs = userWith userLight_username t xs
 292
 293 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 294 userLightWithId t xs = userWith userLight_id t xs
 295 ----------------------------------------------------------------------
 296 users :: Cmd err [UserDB]
 297 users = runOpaQuery queryUserTable
 298
 299 usersLight :: Cmd err [UserLight]
 300 usersLight = map toUserLight <$> users
 301
 302 getUser :: Username -> Cmd err (Maybe UserLight)
 303 getUser u = userLightWithUsername u <$> usersLight
 304
 305 ----------------------------------------------------------------------
 306 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
 307 insertNewUsers newUsers = do
 308   users' <- liftBase $ mapM toUserHash newUsers
 309   insertUsers $ map toUserWrite users'
 310
 311 ----------------------------------------------------------------------
 312 instance DefaultFromField SqlTimestamptz (Maybe UTCTime) where
 313   defaultFromField = fromPGSFromField