src/Gargantext/Database/Action/Query/User.hs

   1 {-|
   2 Module      : Gargantext.Database.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 FlexibleContexts            #-}
  18 {-# LANGUAGE FlexibleInstances           #-}
  19 {-# LANGUAGE MultiParamTypeClasses       #-}
  20 {-# LANGUAGE FunctionalDependencies      #-}
  21 {-# LANGUAGE Arrows                      #-}
  22 {-# LANGUAGE NoImplicitPrelude           #-}
  23 {-# LANGUAGE OverloadedStrings           #-}
  24 {-# LANGUAGE RankNTypes                  #-}
  25
  26 module Gargantext.Database.Action.Query.User
  27   where
  28
  29 import Control.Arrow (returnA)
  30 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  31 import Data.Eq(Eq(..))
  32 import Data.List (find)
  33 import Data.Maybe (Maybe)
  34 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  35 import Data.Text (Text)
  36 import Data.Time (UTCTime)
  37 import GHC.Show(Show(..))
  38 import Gargantext.Core.Types.Individu (Username, arbitraryUsername, User(..), UserId)
  39 import Gargantext.Database.Admin.Types.Errors
  40 import Gargantext.Database.Schema.User
  41 import Gargantext.Database.Admin.Utils
  42 import Gargantext.Prelude
  43 import Opaleye
  44
  45 ------------------------------------------------------------------------
  46 -- TODO: on conflict, nice message
  47 insertUsers :: [UserWrite] -> Cmd err Int64
  48 insertUsers us = mkCmd $ \c -> runInsert_ c insert
  49   where
  50     insert = Insert userTable us rCount Nothing
  51
  52
  53 gargantextUser :: Username -> UserWrite
  54 gargantextUser u = UserDB (Nothing) (pgStrictText "password")
  55                          (Nothing) (pgBool True) (pgStrictText u)
  56                          (pgStrictText "first_name")
  57                          (pgStrictText "last_name")
  58                          (pgStrictText "e@mail")
  59                          (pgBool True) (pgBool True) (Nothing)
  60
  61 insertUsersDemo :: Cmd err Int64
  62 insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
  63
  64 ------------------------------------------------------------------
  65 queryUserTable :: Query UserRead
  66 queryUserTable = queryTable userTable
  67
  68 selectUsersLight :: Query UserRead
  69 selectUsersLight = proc () -> do
  70       row@(UserDB i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
  71       restrict -< i .== 1
  72       --returnA -< User i p ll is un fn ln m iff ive dj
  73       returnA -< row
  74 ------------------------------------------------------------------
  75 -- | Select User with some parameters
  76 -- Not optimized version
  77 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
  78 userWith f t xs = find (\x -> f x == t) xs
  79
  80 -- | Select User with Username
  81 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
  82 userWithUsername t xs = userWith user_username t xs
  83
  84 userWithId :: Int -> [UserDB] -> Maybe UserDB
  85 userWithId t xs = userWith user_id t xs
  86
  87 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
  88 userLightWithUsername t xs = userWith userLight_username t xs
  89
  90 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
  91 userLightWithId t xs = userWith userLight_id t xs
  92
  93
  94 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
  95   queryRunnerColumnDefault = fieldQueryRunnerColumn
  96
  97
  98 users :: Cmd err [UserDB]
  99 users = runOpaQuery queryUserTable
 100
 101 usersLight :: Cmd err [UserLight]
 102 usersLight = map toUserLight <$> users
 103
 104 getUser :: Username -> Cmd err (Maybe UserLight)
 105 getUser u = userLightWithUsername u <$> usersLight
 106