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.Prelude
  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 gargantextUser :: Username -> UserWrite
  60 gargantextUser u = UserDB (Nothing) (pgStrictText "password")
  61                          (Nothing) (pgBool True) (pgStrictText u)
  62                          (pgStrictText "first_name")
  63                          (pgStrictText "last_name")
  64                          (pgStrictText "e@mail")
  65                          (pgBool True) (pgBool True) (Nothing)
  66
  67 insertUsersDemo :: Cmd err Int64
  68 insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
  69
  70 ------------------------------------------------------------------
  71 queryUserTable :: Query UserRead
  72 queryUserTable = queryTable userTable
  73
  74 selectUsersLight :: Query UserRead
  75 selectUsersLight = proc () -> do
  76       row@(UserDB i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
  77       restrict -< i .== 1
  78       --returnA -< User i p ll is un fn ln m iff ive dj
  79       returnA -< row
  80 ------------------------------------------------------------------
  81 -- | Select User with some parameters
  82 -- Not optimized version
  83 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
  84 userWith f t xs = find (\x -> f x == t) xs
  85
  86 -- | Select User with Username
  87 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
  88 userWithUsername t xs = userWith user_username t xs
  89
  90 userWithId :: Int -> [UserDB] -> Maybe UserDB
  91 userWithId t xs = userWith user_id t xs
  92
  93 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
  94 userLightWithUsername t xs = userWith userLight_username t xs
  95
  96 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
  97 userLightWithId t xs = userWith userLight_id t xs
  98
  99
 100 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 101   queryRunnerColumnDefault = fieldQueryRunnerColumn
 102
 103
 104 users :: Cmd err [UserDB]
 105 users = runOpaQuery queryUserTable
 106
 107 usersLight :: Cmd err [UserLight]
 108 usersLight = map toUserLight <$> users
 109
 110 getUser :: Username -> Cmd err (Maybe UserLight)
 111 getUser u = userLightWithUsername u <$> usersLight
 112