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