[REFACT] SocialList (WIP)
[gargantext.git] / src / Gargantext / Database / Query / Table / User.hs
index 5d392402b74845f31dbd3e189a9bce3139e2d228..cd548a59e38b82f3c901358c8d2874d5a1df75a2 100644 (file)
@@ -14,77 +14,102 @@ Functions to deal with users, database side.
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
 {-# LANGUAGE TemplateHaskell             #-}
-{-# LANGUAGE FlexibleContexts            #-}
-{-# LANGUAGE FlexibleInstances           #-}
-{-# LANGUAGE MultiParamTypeClasses       #-}
 {-# LANGUAGE FunctionalDependencies      #-}
 {-# LANGUAGE Arrows                      #-}
-{-# LANGUAGE NoImplicitPrelude           #-}
-{-# LANGUAGE OverloadedStrings           #-}
-{-# LANGUAGE RankNTypes                  #-}
 
 module Gargantext.Database.Query.Table.User
   ( insertUsers
+  , toUserWrite
+  , deleteUsers
+  , updateUserDB
   , queryUserTable
   , getUser
-  , gargUserWith
   , insertUsersDemo
   , selectUsersLightWith
   , userWithUsername
   , userWithId
   , userLightWithId
+  , getUsersWith
+  , getUsersWithId
   , module Gargantext.Database.Schema.User
   )
   where
 
 import Control.Arrow (returnA)
-import Data.Eq(Eq(..))
 import Data.List (find)
-import Data.Maybe (Maybe)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Gargantext.Core.Types.Individu
-import qualified Gargantext.Core.Auth as Auth
+import qualified Gargantext.Prelude.Crypto.Auth as Auth
 import Gargantext.Database.Schema.User
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Opaleye
 
 ------------------------------------------------------------------------
-
-
 -- TODO: on conflict, nice message
 insertUsers :: [UserWrite] -> Cmd err Int64
 insertUsers us = mkCmd $ \c -> runInsert_ c insert
   where
     insert = Insert userTable us rCount Nothing
 
-insertUsersDemo :: Cmd err Int64
-insertUsersDemo = do
-  users <- liftBase arbitraryUsersHash
-  insertUsers $ map (\(u,m,h) -> gargUserWith u m h) users
+deleteUsers :: [Username] -> Cmd err Int64
+deleteUsers us = mkCmd $ \c -> runDelete c userTable
+    (\user -> in_ (map pgStrictText us) (user_username user))
 
------------------------------------------------------------------------
+-- Updates email or password only (for now)
+updateUserDB :: UserWrite -> Cmd err Int64
+updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
+  where
+    updateUserQuery :: UserWrite -> Update Int64
+    updateUserQuery us = Update
+      { uTable      = userTable
+      , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
+                                  -> UserDB _id p' ll su un fn ln em' is ia dj
+                                 )
+      , uWhere      = (\row -> user_username row .== un')
+      , uReturning  = rCount
+      }
+        where
+          UserDB _ p' _ _ un' _ _ em' _ _ _ = us
 
-gargUserWith :: Username -> Email -> Auth.PasswordHash Auth.Argon2 -> UserWrite
-gargUserWith u m (Auth.PasswordHash p) = UserDB (Nothing) (pgStrictText p)
-                         (Nothing) (pgBool True) (pgStrictText u)
-                         (pgStrictText "first_name")
-                         (pgStrictText "last_name")
-                         (pgStrictText m)
-                         (pgBool True) 
-                         (pgBool True) Nothing
+-----------------------------------------------------------------------
+toUserWrite :: NewUser HashPassword -> UserWrite
+toUserWrite (NewUser u m (Auth.PasswordHash p)) = 
+  UserDB (Nothing) (pgStrictText p)
+         (Nothing) (pgBool True) (pgStrictText u)
+         (pgStrictText "first_name")
+         (pgStrictText "last_name")
+         (pgStrictText m)
+         (pgBool True) 
+         (pgBool True) Nothing
 
 ------------------------------------------------------------------
+getUsersWith :: Username -> Cmd err [UserLight]
+getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
+
+selectUsersLightWith :: Username -> Query UserRead
+selectUsersLightWith u = proc () -> do
+      row      <- queryUserTable -< ()
+      restrict -< user_username row .== pgStrictText u
+      returnA  -< row
+
+----------------------------------------------------------
+
+getUsersWithId :: Int -> Cmd err [UserLight]
+getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
+  where
+    selectUsersLightWithId :: Int -> Query UserRead
+    selectUsersLightWithId i = proc () -> do
+          row      <- queryUserTable -< ()
+          restrict -< user_id row .== pgInt4 i
+          returnA  -< row
+
+
+
 queryUserTable :: Query UserRead
 queryUserTable = queryTable userTable
 
-selectUsersLightWith :: Query UserRead
-selectUsersLightWith = proc () -> do
-      row@(UserDB i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
-      restrict -< i .== 1
-      --returnA -< User i p ll is un fn ln m iff ive dj
-      returnA -< row
 ------------------------------------------------------------------
 -- | Select User with some parameters
 -- Not optimized version
@@ -104,11 +129,7 @@ userLightWithUsername t xs = userWith userLight_username t xs
 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 userLightWithId t xs = userWith userLight_id t xs
 
-
-instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
-  queryRunnerColumnDefault = fieldQueryRunnerColumn
-
-
+----------------------------------------------------------------------
 users :: Cmd err [UserDB]
 users = runOpaQuery queryUserTable
 
@@ -118,3 +139,13 @@ usersLight = map toUserLight <$> users
 getUser :: Username -> Cmd err (Maybe UserLight)
 getUser u = userLightWithUsername u <$> usersLight
 
+
+----------------------------------------------------------------------
+insertUsersDemo :: Cmd err Int64
+insertUsersDemo = do
+  users <- liftBase arbitraryUsersHash
+  insertUsers $ map toUserWrite users
+
+----------------------------------------------------------------------
+instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
+  queryRunnerColumnDefault = fieldQueryRunnerColumn