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