{-|
Module      : Gargantext.Database.Query.Table.User
Description : User Database management tools
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

Functions to deal with users, database side.
-}


{-# OPTIONS_GHC -fno-warn-orphans        #-}

{-# LANGUAGE TemplateHaskell             #-}
{-# LANGUAGE FunctionalDependencies      #-}
{-# LANGUAGE Arrows                      #-}

module Gargantext.Database.Query.Table.User
  ( insertUsers
  , toUserWrite
  , deleteUsers
  , updateUserDB
  , queryUserTable
  , getUserHyperdata
  , getUsersWithHyperdata
  , getUser
  , insertNewUsers
  , selectUsersLightWith
  , userWithUsername
  , userWithId
  , userLightWithId
  , getUsersWith
  , getUsersWithId
  , module Gargantext.Database.Schema.User
  )
  where

import Control.Arrow (returnA)
import Control.Lens ((^.))
import Data.List (find)
import Data.Text (Text)
import Data.Time (UTCTime)
import Gargantext.Core.Types.Individu
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Node (node_hyperdata, node_id, queryNodeTable)
import Gargantext.Database.Schema.User
import Gargantext.Prelude
import Opaleye

------------------------------------------------------------------------
-- TODO: on conflict, nice message
insertUsers :: [UserWrite] -> Cmd err Int64
insertUsers :: [UserWrite] -> Cmd err Int64
insertUsers [UserWrite]
us = (Connection -> IO Int64) -> Cmd err Int64
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Int64) -> Cmd err Int64)
-> (Connection -> IO Int64) -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ \Connection
c -> Connection -> Insert Int64 -> IO Int64
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert_ Connection
c Insert Int64
insert
  where
    insert :: Insert Int64
insert = Table UserWrite UserRead
-> [UserWrite]
-> Returning UserRead Int64
-> Maybe OnConflict
-> Insert Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> [fieldsW]
-> Returning fieldsR haskells
-> Maybe OnConflict
-> Insert haskells
Insert Table UserWrite UserRead
userTable [UserWrite]
us Returning UserRead Int64
forall fieldsR. Returning fieldsR Int64
rCount Maybe OnConflict
forall a. Maybe a
Nothing

deleteUsers :: [Username] -> Cmd err Int64
deleteUsers :: [Username] -> Cmd err Int64
deleteUsers [Username]
us = (Connection -> IO Int64) -> Cmd err Int64
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Int64) -> Cmd err Int64)
-> (Connection -> IO Int64) -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ \Connection
c -> Connection -> Delete Int64 -> IO Int64
forall haskells. Connection -> Delete haskells -> IO haskells
runDelete_ Connection
c
                       (Delete Int64 -> IO Int64) -> Delete Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Table UserWrite UserRead
-> (UserRead -> Field SqlBool)
-> Returning UserRead Int64
-> Delete Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> (fieldsR -> Field SqlBool)
-> Returning fieldsR haskells
-> Delete haskells
Delete Table UserWrite UserRead
userTable
                                (\UserRead
user -> [Column PGText] -> Column PGText -> Field SqlBool
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Column a) -> Column a -> Field SqlBool
in_ ((Username -> Column PGText) -> [Username] -> [Column PGText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Username -> Field PGText
Username -> Column PGText
sqlStrictText [Username]
us) (UserRead -> Column PGText
forall id pass llogin suser uname fname lname mail staff active
       djoined.
UserPoly
  id pass llogin suser uname fname lname mail staff active djoined
-> uname
user_username UserRead
user))
                                Returning UserRead Int64
forall fieldsR. Returning fieldsR Int64
rCount

-- Updates email or password only (for now)
updateUserDB :: UserWrite -> Cmd err Int64
updateUserDB :: UserWrite -> Cmd err Int64
updateUserDB UserWrite
us = (Connection -> IO Int64) -> Cmd err Int64
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Int64) -> Cmd err Int64)
-> (Connection -> IO Int64) -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ \Connection
c -> Connection -> Update Int64 -> IO Int64
forall haskells. Connection -> Update haskells -> IO haskells
runUpdate_ Connection
c (UserWrite -> Update Int64
updateUserQuery UserWrite
us)
  where
    updateUserQuery :: UserWrite -> Update Int64
    updateUserQuery :: UserWrite -> Update Int64
updateUserQuery UserWrite
us' = Update :: forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> (fieldsR -> fieldsW)
-> (fieldsR -> Field SqlBool)
-> Returning fieldsR haskells
-> Update haskells
Update
      { uTable :: Table UserWrite UserRead
uTable      = Table UserWrite UserRead
userTable
      , uUpdateWith :: UserRead -> UserWrite
uUpdateWith = (UserRead -> UserRead) -> UserRead -> UserWrite
forall fieldsR fieldsW.
Default Updater fieldsR fieldsW =>
(fieldsR -> fieldsR) -> fieldsR -> fieldsW
updateEasy (\ (UserDB Column PGInt4
_id Column PGText
_p Column PGTimestamptz
ll Column SqlBool
su Column PGText
un Column PGText
fn Column PGText
ln Column PGText
_em Column SqlBool
is Column SqlBool
ia Column PGTimestamptz
dj)
                                  -> Column PGInt4
-> Column PGText
-> Column PGTimestamptz
-> Column SqlBool
-> Column PGText
-> Column PGText
-> Column PGText
-> Column PGText
-> Column SqlBool
-> Column SqlBool
-> Column PGTimestamptz
-> UserRead
forall id pass llogin suser uname fname lname mail staff active
       djoined.
id
-> pass
-> llogin
-> suser
-> uname
-> fname
-> lname
-> mail
-> staff
-> active
-> djoined
-> UserPoly
     id pass llogin suser uname fname lname mail staff active djoined
UserDB Column PGInt4
_id Column PGText
p' Column PGTimestamptz
ll Column SqlBool
su Column PGText
un Column PGText
fn Column PGText
ln Column PGText
em' Column SqlBool
is Column SqlBool
ia Column PGTimestamptz
dj
                                 )
      , uWhere :: UserRead -> Field SqlBool
uWhere      = (\UserRead
row -> UserRead -> Column PGText
forall id pass llogin suser uname fname lname mail staff active
       djoined.
UserPoly
  id pass llogin suser uname fname lname mail staff active djoined
-> uname
user_username UserRead
row Column PGText -> Column PGText -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== Column PGText
un')
      , uReturning :: Returning UserRead Int64
uReturning  = Returning UserRead Int64
forall fieldsR. Returning fieldsR Int64
rCount
      }
        where
          UserDB Maybe (Column PGInt4)
_ Column PGText
p' Maybe (Column PGTimestamptz)
_ Column SqlBool
_ Column PGText
un' Column PGText
_ Column PGText
_ Column PGText
em' Column SqlBool
_ Column SqlBool
_ Maybe (Column PGTimestamptz)
_ = UserWrite
us'

-----------------------------------------------------------------------
toUserWrite :: NewUser HashPassword -> UserWrite
toUserWrite :: NewUser HashPassword -> UserWrite
toUserWrite (NewUser Username
u Username
m (Auth.PasswordHash Username
p)) = 
  Maybe (Column PGInt4)
-> Column PGText
-> Maybe (Column PGTimestamptz)
-> Column SqlBool
-> Column PGText
-> Column PGText
-> Column PGText
-> Column PGText
-> Column SqlBool
-> Column SqlBool
-> Maybe (Column PGTimestamptz)
-> UserWrite
forall id pass llogin suser uname fname lname mail staff active
       djoined.
id
-> pass
-> llogin
-> suser
-> uname
-> fname
-> lname
-> mail
-> staff
-> active
-> djoined
-> UserPoly
     id pass llogin suser uname fname lname mail staff active djoined
UserDB (Maybe (Column PGInt4)
forall a. Maybe a
Nothing) (Username -> Field PGText
sqlStrictText Username
p)
         (Maybe (Column PGTimestamptz)
forall a. Maybe a
Nothing) (Bool -> Column SqlBool
pgBool Bool
True) (Username -> Field PGText
sqlStrictText Username
u)
         (Username -> Field PGText
sqlStrictText Username
"first_name")
         (Username -> Field PGText
sqlStrictText Username
"last_name")
         (Username -> Field PGText
sqlStrictText Username
m)
         (Bool -> Column SqlBool
pgBool Bool
True)
         (Bool -> Column SqlBool
pgBool Bool
True) Maybe (Column PGTimestamptz)
forall a. Maybe a
Nothing

------------------------------------------------------------------
getUsersWith :: Username -> Cmd err [UserLight]
getUsersWith :: Username -> Cmd err [UserLight]
getUsersWith Username
u = (UserDB -> UserLight) -> [UserDB] -> [UserLight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map UserDB -> UserLight
toUserLight ([UserDB] -> [UserLight]) -> m [UserDB] -> m [UserLight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Select UserRead -> Cmd err [UserDB]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Username -> Select UserRead
selectUsersLightWith Username
u)

selectUsersLightWith :: Username -> Query UserRead
selectUsersLightWith :: Username -> Select UserRead
selectUsersLightWith Username
u = proc () -> do
      UserRead
row      <- Select UserRead
queryUserTable -< ()
      SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< UserRead -> Column PGText
forall id pass llogin suser uname fname lname mail staff active
       djoined.
UserPoly
  id pass llogin suser uname fname lname mail staff active djoined
-> uname
user_username UserRead
row Column PGText -> Column PGText -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== Username -> Field PGText
sqlStrictText Username
u
      SelectArr UserRead UserRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA  -< UserRead
row

----------------------------------------------------------
getUsersWithId :: Int -> Cmd err [UserLight]
getUsersWithId :: Int -> Cmd err [UserLight]
getUsersWithId Int
i = (UserDB -> UserLight) -> [UserDB] -> [UserLight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map UserDB -> UserLight
toUserLight ([UserDB] -> [UserLight]) -> m [UserDB] -> m [UserLight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Select UserRead -> Cmd err [UserDB]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Int -> Select UserRead
selectUsersLightWithId Int
i)
  where
    selectUsersLightWithId :: Int -> Query UserRead
    selectUsersLightWithId :: Int -> Select UserRead
selectUsersLightWithId Int
i' = proc () -> do
          UserRead
row      <- Select UserRead
queryUserTable -< ()
          SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< UserRead -> Column PGInt4
forall id pass llogin suser uname fname lname mail staff active
       djoined.
UserPoly
  id pass llogin suser uname fname lname mail staff active djoined
-> id
user_id UserRead
row Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== Int -> Field PGInt4
sqlInt4 Int
i'
          SelectArr UserRead UserRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA  -< UserRead
row


queryUserTable :: Query UserRead
queryUserTable :: Select UserRead
queryUserTable = Table UserWrite UserRead -> Select UserRead
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table UserWrite UserRead
userTable

----------------------------------------------------------------------
getUserHyperdata :: Int -> Cmd err [HyperdataUser]
getUserHyperdata :: Int -> Cmd err [HyperdataUser]
getUserHyperdata Int
i = do
  Select (Column PGJsonb) -> Cmd err [HyperdataUser]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Int -> Select (Column PGJsonb)
selectUserHyperdataWithId Int
i)
  where
    selectUserHyperdataWithId :: Int -> Query (Column PGJsonb)
    selectUserHyperdataWithId :: Int -> Select (Column PGJsonb)
selectUserHyperdataWithId Int
i' = proc () -> do
      NodeRead
row      <- Query NodeRead
queryNodeTable -< ()
      SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< NodeRead
rowNodeRead
-> Getting (Column PGInt4) NodeRead (Column PGInt4)
-> Column PGInt4
forall s a. s -> Getting a s a -> a
^.Getting (Column PGInt4) NodeRead (Column PGInt4)
forall id1 hash_id typename user_id parent_id name date hyperdata
       id2.
Lens
  (NodePoly
     id1 hash_id typename user_id parent_id name date hyperdata)
  (NodePoly
     id2 hash_id typename user_id parent_id name date hyperdata)
  id1
  id2
node_id Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== (Int -> Field PGInt4
sqlInt4 Int
i')
      SelectArr (Column PGJsonb) (Column PGJsonb)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA  -< NodeRead
rowNodeRead
-> Getting (Column PGJsonb) NodeRead (Column PGJsonb)
-> Column PGJsonb
forall s a. s -> Getting a s a -> a
^.Getting (Column PGJsonb) NodeRead (Column PGJsonb)
forall id1 hash_id typename user_id parent_id name date hyperdata
       hyperdata2.
Lens
  (NodePoly
     id1 hash_id typename user_id parent_id name date hyperdata)
  (NodePoly
     id1 hash_id typename user_id parent_id name date hyperdata2)
  hyperdata
  hyperdata2
node_hyperdata

getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
getUsersWithHyperdata Int
i = do
  [UserLight]
u <- Int -> Cmd err [UserLight]
forall err. Int -> Cmd err [UserLight]
getUsersWithId Int
i
  [HyperdataUser]
h <- Int -> Cmd err [HyperdataUser]
forall err. Int -> Cmd err [HyperdataUser]
getUserHyperdata Int
i
  [(UserLight, HyperdataUser)] -> m [(UserLight, HyperdataUser)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(UserLight, HyperdataUser)] -> m [(UserLight, HyperdataUser)])
-> [(UserLight, HyperdataUser)] -> m [(UserLight, HyperdataUser)]
forall a b. (a -> b) -> a -> b
$ [UserLight] -> [HyperdataUser] -> [(UserLight, HyperdataUser)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UserLight]
u [HyperdataUser]
h
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
userWith :: (a -> a1) -> a1 -> t a -> Maybe a
userWith a -> a1
f a1
t t a
xs = (a -> Bool) -> t a -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\a
x -> a -> a1
f a
x a1 -> a1 -> Bool
forall a. Eq a => a -> a -> Bool
== a1
t) t a
xs

-- | Select User with Username
userWithUsername :: Text -> [UserDB] -> Maybe UserDB
userWithUsername :: Username -> [UserDB] -> Maybe UserDB
userWithUsername Username
t [UserDB]
xs = (UserDB -> Username) -> Username -> [UserDB] -> Maybe UserDB
forall a1 (t :: * -> *) a.
(Eq a1, Foldable t) =>
(a -> a1) -> a1 -> t a -> Maybe a
userWith UserDB -> Username
forall id pass llogin suser uname fname lname mail staff active
       djoined.
UserPoly
  id pass llogin suser uname fname lname mail staff active djoined
-> uname
user_username Username
t [UserDB]
xs

userWithId :: Int -> [UserDB] -> Maybe UserDB
userWithId :: Int -> [UserDB] -> Maybe UserDB
userWithId Int
t [UserDB]
xs = (UserDB -> Int) -> Int -> [UserDB] -> Maybe UserDB
forall a1 (t :: * -> *) a.
(Eq a1, Foldable t) =>
(a -> a1) -> a1 -> t a -> Maybe a
userWith UserDB -> Int
forall id pass llogin suser uname fname lname mail staff active
       djoined.
UserPoly
  id pass llogin suser uname fname lname mail staff active djoined
-> id
user_id Int
t [UserDB]
xs

userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
userLightWithUsername :: Username -> [UserLight] -> Maybe UserLight
userLightWithUsername Username
t [UserLight]
xs = (UserLight -> Username)
-> Username -> [UserLight] -> Maybe UserLight
forall a1 (t :: * -> *) a.
(Eq a1, Foldable t) =>
(a -> a1) -> a1 -> t a -> Maybe a
userWith UserLight -> Username
userLight_username Username
t [UserLight]
xs

userLightWithId :: Int -> [UserLight] -> Maybe UserLight
userLightWithId :: Int -> [UserLight] -> Maybe UserLight
userLightWithId Int
t [UserLight]
xs = (UserLight -> Int) -> Int -> [UserLight] -> Maybe UserLight
forall a1 (t :: * -> *) a.
(Eq a1, Foldable t) =>
(a -> a1) -> a1 -> t a -> Maybe a
userWith UserLight -> Int
userLight_id Int
t [UserLight]
xs
----------------------------------------------------------------------
users :: Cmd err [UserDB]
users :: m [UserDB]
users = Select UserRead -> Cmd err [UserDB]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery Select UserRead
queryUserTable

usersLight :: Cmd err [UserLight]
usersLight :: m [UserLight]
usersLight = (UserDB -> UserLight) -> [UserDB] -> [UserLight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map UserDB -> UserLight
toUserLight ([UserDB] -> [UserLight]) -> m [UserDB] -> m [UserLight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [UserDB]
forall err. Cmd err [UserDB]
users

getUser :: Username -> Cmd err (Maybe UserLight)
getUser :: Username -> Cmd err (Maybe UserLight)
getUser Username
u = Username -> [UserLight] -> Maybe UserLight
userLightWithUsername Username
u ([UserLight] -> Maybe UserLight)
-> m [UserLight] -> m (Maybe UserLight)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [UserLight]
forall err. Cmd err [UserLight]
usersLight

----------------------------------------------------------------------
insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
insertNewUsers [NewUser GargPassword]
newUsers = do
  [NewUser HashPassword]
users' <- IO [NewUser HashPassword] -> m [NewUser HashPassword]
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [NewUser HashPassword] -> m [NewUser HashPassword])
-> IO [NewUser HashPassword] -> m [NewUser HashPassword]
forall a b. (a -> b) -> a -> b
$ (NewUser GargPassword -> IO (NewUser HashPassword))
-> [NewUser GargPassword] -> IO [NewUser HashPassword]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NewUser GargPassword -> IO (NewUser HashPassword)
forall (m :: * -> *).
MonadIO m =>
NewUser GargPassword -> m (NewUser HashPassword)
toUserHash [NewUser GargPassword]
newUsers
  [UserWrite] -> Cmd err Int64
forall err. [UserWrite] -> Cmd err Int64
insertUsers ([UserWrite] -> Cmd err Int64) -> [UserWrite] -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ (NewUser HashPassword -> UserWrite)
-> [NewUser HashPassword] -> [UserWrite]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map NewUser HashPassword -> UserWrite
toUserWrite [NewUser HashPassword]
users'

----------------------------------------------------------------------
instance DefaultFromField PGTimestamptz (Maybe UTCTime) where
  defaultFromField :: FromField PGTimestamptz (Maybe UTCTime)
defaultFromField = FromField PGTimestamptz (Maybe UTCTime)
forall haskell pgType.
FromField haskell =>
FromField pgType haskell
fieldQueryRunnerColumn