Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev
[gargantext.git] / src / Gargantext / Database / Schema / User.hs
index 1938b0930c0dc92948d0731f24610d05ac44f041..7c39d307e8fb914b53f2c359d08997a11b2d2150 100644 (file)
@@ -10,158 +10,130 @@ Portability : POSIX
 Functions to deal with users, database side.
 -}
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
-{-# LANGUAGE TemplateHaskell             #-}
-{-# LANGUAGE FlexibleInstances           #-}
-{-# LANGUAGE MultiParamTypeClasses       #-}
+{-# LANGUAGE DeriveAnyClass              #-}
 {-# LANGUAGE FunctionalDependencies      #-}
 {-# LANGUAGE Arrows                      #-}
-{-# LANGUAGE NoImplicitPrelude           #-}
-{-# LANGUAGE OverloadedStrings           #-}
-{-# LANGUAGE RankNTypes                  #-}
+{-# LANGUAGE TemplateHaskell             #-}
 
 module Gargantext.Database.Schema.User where
 
-import Control.Arrow (returnA)
-import Control.Lens.TH (makeLensesWith, abbreviatedFields)
-import Data.Eq(Eq(..))
-import Data.List (find)
-import Data.Maybe (Maybe)
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Morpheus.Types (GQLType(typeOptions))
 import Data.Text (Text)
 import Data.Time (UTCTime)
-import GHC.Show(Show(..))
-import Gargantext.Core.Types.Individu (Username, arbitraryUsername)
-import Gargantext.Database.Utils
+import qualified Gargantext.API.GraphQL.Utils as GAGU
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Types.Individu (GargPassword, toGargPassword)
+import Gargantext.Database.Prelude (fromField')
 import Gargantext.Prelude
-import Opaleye
+import GHC.Generics (Generic)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
+import Data.Aeson.TH (deriveJSON)
 
-------------------------------------------------------------------------
+-- FIXME PLZ : the import below leads to an error, why ?
+-- import Gargantext.Database.Schema.Prelude hiding (makeLensesWith, abbreviatedFields, makeAdaptorAndInstance)
 
+-- When FIXED : Imports to remove:
+import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Opaleye hiding (FromField)
+import Opaleye.Internal.Table (Table(..))
 ------------------------------------------------------------------------
-type UserId = Int
+data UserLight = UserLight { userLight_id                   :: !Int
+                           , userLight_username             :: !Text
+                           , userLight_email                :: !Text
+                           , userLight_password             :: !GargPassword
+                           , userLight_forgot_password_uuid :: !(Maybe Text)
+                           } deriving (Show, Generic)
+instance GQLType UserLight where
+  typeOptions _ = GAGU.unPrefix "userLight_"
+
+toUserLight :: UserDB -> UserLight
+toUserLight (UserDB { user_id
+                    , user_password
+                    , user_username
+                    , user_email }) = UserLight { userLight_id = user_id
+                                                , userLight_username = user_username
+                                                , userLight_email = user_email
+                                                , userLight_password = toGargPassword user_password
+                                                , userLight_forgot_password_uuid = Nothing }
 
 
-data UserLight = UserLight { userLight_id   :: Int
-                           , userLight_username :: Text
-                           , userLight_email    :: Text
-                           } deriving (Show)
-
-toUserLight :: User -> UserLight
-toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
-
 data UserPoly id pass llogin suser
               uname fname lname
-              mail staff active djoined = User { user_id          :: id
-                                               , user_password    :: pass
-                                               , user_lastLogin   :: llogin
-                                               , user_isSuperUser :: suser
-
-                                               , user_username    :: uname
-                                               , user_firstName   :: fname
-                                               , user_lastName    :: lname
-                                               , user_email       :: mail
-
-                                               , user_isStaff     :: staff
-                                               , user_isActive    :: active
-                                               , user_dateJoined  :: djoined
-                                               } deriving (Show)
-
-type UserWrite = UserPoly (Maybe (Column PGInt4))        (Column PGText)
-                          (Maybe (Column PGTimestamptz)) (Column PGBool)
-                                 (Column PGText)         (Column PGText)
-                                 (Column PGText)         (Column PGText)
-                                 (Column PGBool)         (Column PGBool)
-                                 (Maybe (Column PGTimestamptz))
-
-type UserRead  = UserPoly        (Column PGInt4)         (Column PGText)
-                                 (Column PGTimestamptz)  (Column PGBool)
-                                 (Column PGText)         (Column PGText)
-                                 (Column PGText)         (Column PGText)
-                                 (Column PGBool)         (Column PGBool)
-                                 (Column PGTimestamptz)
-
-type User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
-
-$(makeAdaptorAndInstance "pUser"     ''UserPoly)
+              mail staff active djoined
+              fpuuid =
+    UserDB { user_id                   :: !id
+           , user_password             :: !pass
+           , user_lastLogin            :: !llogin
+           , user_isSuperUser          :: !suser
+
+           , user_username             :: !uname
+           , user_firstName            :: !fname
+           , user_lastName             :: !lname
+           , user_email                :: !mail
+
+           , user_isStaff              :: !staff
+           , user_isActive             :: !active
+           , user_dateJoined           :: !djoined
+
+           , user_forgot_password_uuid :: !fpuuid
+           } deriving (Show, Generic)
+
+
+type UserWrite = UserPoly (Maybe (Column SqlInt4))        (Column SqlText)
+                          (Maybe (Column SqlTimestamptz)) (Column SqlBool)
+                                 (Column SqlText)         (Column SqlText)
+                                 (Column SqlText)         (Column SqlText)
+                                 (Column SqlBool)         (Column SqlBool)
+                                 (Maybe (Column SqlTimestamptz))
+                                 (Maybe (Column SqlText))
+
+type UserRead  = UserPoly        (Column SqlInt4)         (Column SqlText)
+                                 (Column SqlTimestamptz)  (Column SqlBool)
+                                 (Column SqlText)         (Column SqlText)
+                                 (Column SqlText)         (Column SqlText)
+                                 (Column SqlBool)         (Column SqlBool)
+                                 (Column SqlTimestamptz)
+                                 (Column SqlText)
+
+type UserReadNull = UserPoly     (Column (Nullable SqlInt4))         (Column (Nullable SqlText))
+                                 (Column (Nullable SqlTimestamptz))  (Column (Nullable SqlBool))
+                                 (Column (Nullable SqlText))         (Column (Nullable SqlText))
+                                 (Column (Nullable SqlText))         (Column (Nullable SqlText))
+                                 (Column (Nullable SqlBool))         (Column (Nullable SqlBool))
+                                 (Column (Nullable SqlTimestamptz))
+                                 (Column (Nullable SqlText))
+
+type UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime (Maybe Text)
+
+$(makeAdaptorAndInstance "pUserDB"   ''UserPoly)
 $(makeLensesWith abbreviatedFields   ''UserPoly)
 
-
 userTable :: Table UserWrite UserRead
-userTable = Table "auth_user" (pUser User { user_id      = optional "id"
-                                          , user_password    = required "password"
-                                          , user_lastLogin   = optional "last_login"
-                                          , user_isSuperUser = required "is_superuser"
-                                          , user_username    = required "username"
-                                          , user_firstName   = required "first_name"
-                                          , user_lastName    = required "last_name"
-                                          , user_email       = required "email"
-                                          , user_isStaff     = required "is_staff"
-                                          , user_isActive    = required "is_active"
-                                          , user_dateJoined  = optional "date_joined"
-                                          }
-                              )
-
--- TODO: on conflict, nice message
-insertUsers :: [UserWrite] -> Cmd err Int64
-insertUsers us = mkCmd $ \c -> runInsertMany c userTable us
-
-
-gargantextUser :: Username -> UserWrite
-gargantextUser u = User (Nothing) (pgStrictText "password")
-                         (Nothing) (pgBool True) (pgStrictText u)
-                         (pgStrictText "first_name")
-                         (pgStrictText "last_name")
-                         (pgStrictText "e@mail")
-                         (pgBool True) (pgBool True) (Nothing)
-
-insertUsersDemo :: Cmd err Int64
-insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
-
-
-------------------------------------------------------------------
-queryUserTable :: Query UserRead
-queryUserTable = queryTable userTable
-
-selectUsersLight :: Query UserRead
-selectUsersLight = proc () -> do
-      row@(User 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
-userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
-userWith f t xs = find (\x -> f x == t) xs
-
--- | Select User with Username
-userWithUsername :: Text -> [User] -> Maybe User
-userWithUsername t xs = userWith user_username t xs
-
-userWithId :: Int -> [User] -> Maybe User
-userWithId t xs = userWith user_id t xs
-
-userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
-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 [User]
-users = runOpaQuery queryUserTable
-
-usersLight :: Cmd err [UserLight]
-usersLight = map toUserLight <$> users
-
-getUser :: Username -> Cmd err (Maybe UserLight)
-getUser u = userLightWithUsername u <$> usersLight
-
-
+userTable = Table "auth_user"
+  (pUserDB UserDB { user_id                   = optionalTableField "id"
+                  , user_password             = requiredTableField "password"
+                  , user_lastLogin            = optionalTableField "last_login"
+                  , user_isSuperUser          = requiredTableField "is_superuser"
+                  , user_username             = requiredTableField "username"
+                  , user_firstName            = requiredTableField "first_name"
+                  , user_lastName             = requiredTableField "last_name"
+                  , user_email                = requiredTableField "email"
+                  , user_isStaff              = requiredTableField "is_staff"
+                  , user_isActive             = requiredTableField "is_active"
+                  , user_dateJoined           = optionalTableField "date_joined"
+                  , user_forgot_password_uuid = optionalTableField "forgot_password_uuid"
+                  }
+      )
+
+instance FromField UserLight where
+  fromField = fromField'
+
+instance FromField UserDB where
+  fromField = fromField'
+
+$(deriveJSON (unPrefix "userLight_") ''UserLight)
+$(deriveJSON (unPrefix "user_") ''UserPoly)