Skip to content

haskell-gargantext
haskell-gargantext
Commit ba856c93 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FIX] Merge

parents d03768cd 2e060925
Hide whitespace changes
Inline Side-by-side
Showing with 425 additions and 89 deletions
gargantext.cabal
View file @ ba856c93
cabal-version: 0.0.5.8.9.1
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.5.8.9.1
version: 0.0.5.8.9.1
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -145,6 +145,7 @@ library
Gargantext.API.Swagger
Gargantext.API.Table
Gargantext.API.ThrowAll
Gargantext.API.Types
Gargantext.Core.Ext.IMT
Gargantext.Core.Ext.IMTUser
Gargantext.Core.Flow.Ngrams
......@@ -411,6 +412,7 @@ library
, matrix
, monad-control
, monad-logger
, monad-logger-aeson
, morpheus-graphql
, morpheus-graphql-app
, morpheus-graphql-core
......
package.yaml
View file @ ba856c93
......@@ -199,6 +199,7 @@ library:
- matrix
- monad-control
- monad-logger
- monad-logger-aeson
- morpheus-graphql
- morpheus-graphql-app
- morpheus-graphql-core
......
src/Gargantext/API/Admin/Auth.hs
View file @ ba856c93
......@@ -22,25 +22,49 @@ TODO-ACCESS Critical
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Admin.Auth
( auth
, forgotPassword
, forgotPasswordAsync
, withAccess
, ForgotPasswordAPI
, ForgotPasswordAsyncParams
, ForgotPasswordAsyncAPI
)
where
import Control.Lens (view)
import Control.Lens (view, (#))
--import Control.Monad.Logger.Aeson
import Data.Aeson
import Data.Swagger (ToSchema(..))
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8)
import qualified Data.Text.Lazy.Encoding as LE
import Data.UUID (UUID, fromText, toText)
import Data.UUID.V4 (nextRandom)
import GHC.Generics (Generic)
import Servant
import Servant.Auth.Server
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import qualified Text.Blaze.Html.Renderer.Text as H
import qualified Text.Blaze.Html5 as H
--import qualified Text.Blaze.Html5.Attributes as HA
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.API.Job (jobLogSuccess)
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError)
import Gargantext.API.Types
import Gargantext.Core.Mail (MailModel(..), mail)
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
import Gargantext.Core.Utils (randomString)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.User
......@@ -59,7 +83,7 @@ makeTokenForUser uid = do
jwtS <- view $ settings . jwtSettings
e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
-- TODO-SECURITY here we can implement token expiration ^^.
either joseError (pure . toStrict . decodeUtf8) e
either joseError (pure . toStrict . LE.decodeUtf8) e
-- TODO not sure about the encoding...
checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
......@@ -70,7 +94,7 @@ checkAuthRequest u (GargPassword p) = do
candidate <- head <$> getUsersWith u
case candidate of
Nothing -> pure InvalidUser
Just (UserLight id _u _email (GargPassword h)) ->
Just (UserLight { userLight_password = GargPassword h, .. }) ->
case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
Auth.PasswordCheckFail -> pure InvalidPassword
Auth.PasswordCheckSuccess -> do
......@@ -79,7 +103,7 @@ checkAuthRequest u (GargPassword p) = do
Nothing -> pure InvalidUser
Just uid -> do
token <- makeTokenForUser uid
pure $ Valid token uid id
pure $ Valid token uid userLight_id
auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
=> AuthRequest -> Cmd' env err AuthResponse
......@@ -134,3 +158,147 @@ User can create Team in Teams Folder.
User can invite User in Team as NodeNode only if Team in his parents.
All users can access to the Team folder as if they were owner.
-}
newtype ForgotPasswordAsyncParams =
ForgotPasswordAsyncParams { email :: Text }
deriving (Generic, Show)
instance FromJSON ForgotPasswordAsyncParams where
parseJSON = genericParseJSON defaultOptions
instance ToJSON ForgotPasswordAsyncParams where
toJSON = genericToJSON defaultOptions
instance ToSchema ForgotPasswordAsyncParams
type ForgotPasswordAPI = Summary "Forgot password POST API"
:> ReqBody '[JSON] ForgotPasswordRequest
:> Post '[JSON] ForgotPasswordResponse
:<|> Summary "Forgot password GET API"
:> QueryParam "uuid" Text
:> Get '[HTML] Text
forgotPassword :: GargServer ForgotPasswordAPI
-- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
forgotPassword = forgotPasswordPost :<|> forgotPasswordGet
forgotPasswordPost :: ( HasConnectionPool env, HasConfig env, HasMail env)
=> ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
forgotPasswordPost (ForgotPasswordRequest email) = do
us <- getUsersWithEmail email
case us of
[u] -> forgotUserPassword u
_ -> pure ()
-- NOTE Sending anything else here could leak information about
-- users' emails
pure $ ForgotPasswordResponse "ok"
forgotPasswordGet :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
=> Maybe Text -> Cmd' env err Text
forgotPasswordGet Nothing = pure ""
forgotPasswordGet (Just uuid) = do
let mUuid = fromText uuid
case mUuid of
Nothing -> throwError $ _ServerError # err404 { errBody = "Not found" }
Just uuid' -> do
-- fetch user
us <- getUsersWithForgotPasswordUUID uuid'
case us of
[u] -> forgotPasswordGetUser u
_ -> throwError $ _ServerError # err404 { errBody = "Not found" }
---------------------
forgotPasswordGetUser :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
=> UserLight -> Cmd' env err Text
forgotPasswordGetUser (UserLight { .. }) = do
-- pick some random password
password <- liftBase $ randomString 10
-- set it as user's password
hashed <- liftBase $ Auth.hashPassword $ Auth.mkPassword password
let hashed' = Auth.unPasswordHash hashed
let userPassword = UserLight { userLight_password = GargPassword hashed', .. }
_ <- updateUserPassword userPassword
-- display this briefly in the html
-- clear the uuid so that the page can't be refreshed
_ <- updateUserForgotPasswordUUID $ UserLight { userLight_forgot_password_uuid = Nothing, .. }
pure $ toStrict $ H.renderHtml $
H.docTypeHtml $ do
H.html $ do
H.head $ do
H.title "Gargantext - forgot password"
H.body $ do
H.h1 "Forgot password"
H.p $ do
H.span "Here is your password (will be shown only once): "
H.b $ H.toHtml password
forgotUserPassword :: (HasConnectionPool env, HasConfig env, HasMail env)
=> UserLight -> Cmd' env err ()
forgotUserPassword (UserLight { .. }) = do
--printDebug "[forgotUserPassword] userLight_id" userLight_id
--logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
-- generate uuid for email
uuid <- generateForgotPasswordUUID
let userUUID = UserLight { userLight_forgot_password_uuid = Just $ toText uuid, .. }
-- save user with that uuid
_ <- updateUserForgotPasswordUUID userUUID
-- send email with uuid link
cfg <- view $ mailSettings
mail cfg (ForgotPassword { user = userUUID })
-- on uuid link enter: change user password and present it to the
-- user
pure ()
--------------------------
-- Generate a unique (in whole DB) UUID for passwords.
generateForgotPasswordUUID :: (HasConnectionPool env, HasConfig env, HasMail env)
=> Cmd' env err UUID
generateForgotPasswordUUID = do
uuid <- liftBase $ nextRandom
us <- getUsersWithForgotPasswordUUID uuid
case us of
[] -> pure uuid
_ -> generateForgotPasswordUUID
----------------------------
-- NOTE THe async endpoint is better for the "forget password"
-- request, because the delay in email sending etc won't reveal to
-- malicious users emails of our users in the db
type ForgotPasswordAsyncAPI = Summary "Forgot password asnc"
:> AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog
forgotPasswordAsync :: GargServer ForgotPasswordAsyncAPI
forgotPasswordAsync =
serveJobsAPI $
JobFunction (\p log' ->
forgotPasswordAsync' p (liftBase . log')
)
forgotPasswordAsync' :: (FlowCmdM env err m)
=> ForgotPasswordAsyncParams
-> (JobLog -> m ())
-> m JobLog
forgotPasswordAsync' (ForgotPasswordAsyncParams { email }) logStatus = do
let jobLog = JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
logStatus jobLog
printDebug "[forgotPasswordAsync'] email" email
_ <- forgotPasswordPost $ ForgotPasswordRequest { _fpReq_email = email }
pure $ jobLogSuccess jobLog
src/Gargantext/API/Admin/Auth/Types.hs
View file @ ba856c93
......@@ -106,4 +106,21 @@ instance Arbitrary AuthValid where
, u <- [1..3]
]
data PathId = PathNode NodeId | PathNodeNode ListId DocId
\ No newline at end of file
data PathId = PathNode NodeId | PathNodeNode ListId DocId
---------------------------
type Email = Text
data ForgotPasswordRequest = ForgotPasswordRequest { _fpReq_email :: Email }
deriving (Generic )
$(deriveJSON (unPrefix "_fpReq_") ''ForgotPasswordRequest)
instance ToSchema ForgotPasswordRequest where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpReq_")
data ForgotPasswordResponse = ForgotPasswordResponse { _fpRes_status :: Text }
deriving (Generic )
$(deriveJSON (unPrefix "_fpRes_") ''ForgotPasswordResponse)
instance ToSchema ForgotPasswordResponse where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpRes_")
src/Gargantext/API/Admin/Settings.hs
View file @ ba856c93
......@@ -21,7 +21,7 @@ module Gargantext.API.Admin.Settings
-- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Codec.Serialise (Serialise(), serialise)
import Control.Lens
import Control.Monad.Logger
import Control.Monad.Logger (LogLevel(..))
import Control.Monad.Reader
import Data.Maybe (fromMaybe)
import Data.Pool (Pool, createPool)
......
src/Gargantext/API/Admin/Types.hs
View file @ ba856c93
......@@ -5,7 +5,7 @@
module Gargantext.API.Admin.Types where
import Control.Lens
import Control.Monad.Logger
import Control.Monad.Logger (LogLevel)
import Data.ByteString (ByteString)
import GHC.Enum
import GHC.Generics (Generic)
......
src/Gargantext/API/Client.hs
View file @ ba856c93
......@@ -13,6 +13,7 @@ import Data.Text (Text)
import Data.Time.Clock
import Data.Vector (Vector)
import Gargantext.API
import Gargantext.API.Admin.Auth (ForgotPasswordAsyncParams)
import Gargantext.API.Admin.Auth.Types hiding (Token)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Count
......@@ -64,6 +65,13 @@ getBackendVersion :: ClientM Text
-- * auth API
postAuth :: AuthRequest -> ClientM AuthResponse
forgotPasswordPost :: ForgotPasswordRequest -> ClientM ForgotPasswordResponse
forgotPasswordGet :: Maybe Text -> ClientM Text
postForgotPasswordAsync :: ClientM (JobStatus 'Safe JobLog)
postForgotPasswordAsyncJob :: JobInput Maybe ForgotPasswordAsyncParams -> ClientM (JobStatus 'Safe JobLog)
killForgotPasswordAsyncJob :: JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
pollForgotPasswordAsyncJob :: JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
waitForgotPasswordAsyncJob :: JobID 'Unsafe -> ClientM (JobOutput JobLog)
-- * admin api
getRoots :: Token -> ClientM [Node HyperdataUser]
......@@ -438,6 +446,13 @@ clientApi = client (flatten apiGarg)
getMetricsSample :<|> getMetricSample :<|> _ = client (Proxy :: Proxy (Flat EkgAPI))
postAuth
:<|> forgotPasswordPost
:<|> forgotPasswordGet
:<|> postForgotPasswordAsync
:<|> postForgotPasswordAsyncJob
:<|> killForgotPasswordAsyncJob
:<|> pollForgotPasswordAsyncJob
:<|> waitForgotPasswordAsyncJob
:<|> getBackendVersion
:<|> getRoots
:<|> putRoots
......
src/Gargantext/API/GraphQL.hs
View file @ ba856c93
{-# OPTIONS_GHC -fprint-potential-instances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-} -- permit duplications for field names in multiple constructors
{-# LANGUAGE KindSignatures #-} -- for use of Endpoint (name :: Symbol)
......@@ -9,7 +11,6 @@ module Gargantext.API.GraphQL where
import Data.ByteString.Lazy.Char8
( ByteString
)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Map (Map)
import Data.Morpheus
( App
......@@ -41,19 +42,16 @@ import qualified Gargantext.API.GraphQL.User as GQLUser
import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.API.Types
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
import Gargantext.Prelude
import GHC.Generics (Generic)
import Network.HTTP.Media ((//), (/:))
import qualified Prelude
import Servant
( (:<|>) (..)
, (:>)
, Accept (..)
, Get
, JSON
, MimeRender (..)
, Post
, ReqBody
, ServerT
......@@ -62,6 +60,7 @@ import qualified Servant.Auth as SA
import qualified Servant.Auth.Server as SAS
import Gargantext.API.Admin.Types (HasSettings)
-- | Represents possible GraphQL queries.
data Query m
= Query
......@@ -124,13 +123,6 @@ app = deriveApp rootResolver
-- Now for some boilerplate to integrate the above GraphQL app with
-- servant.
-- | HTML type is needed for the GraphQL Playground.
data HTML deriving (Typeable)
instance Accept HTML where
contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
instance MimeRender HTML ByteString where
mimeRender _ = Prelude.id
-- | Servant route for the app we defined above.
type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
-- type Schema = "schema" :> Get '[PlainText] Text
......
src/Gargantext/API/GraphQL/UserInfo.hs
View file @ ba856c93
......@@ -137,10 +137,8 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
-- The userLight_email is more important: it is used for login and sending mail.
-- Therefore we update ui_cwTouchMail and userLight_email.
-- ui_cwTouchMail is to be removed in the future.
let u' = UserLight { userLight_id
, userLight_username
, userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata
, userLight_password }
let u' = UserLight { userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata
, .. }
-- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
_ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
_ <- lift $ updateUserEmail u'
......
src/Gargantext/API/Ngrams/List.hs
View file @ ba856c93
......@@ -16,7 +16,6 @@ module Gargantext.API.Ngrams.List
where
import Control.Lens hiding (elements, Indexed)
import Data.Aeson
import Data.Either (Either(..))
import Data.HashMap.Strict (HashMap)
import Data.Map (Map, toList)
......@@ -31,6 +30,7 @@ import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer)
import Gargantext.API.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
import Gargantext.Core.Text.Terms.WithList (buildPatterns, termsInText)
......@@ -46,7 +46,6 @@ import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node (_node_parent_id)
import Gargantext.Database.Types (Indexed(..))
import Gargantext.Prelude
import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import qualified Data.ByteString.Lazy as BSL
......@@ -67,12 +66,6 @@ type GETAPI = Summary "Get List"
getApi :: GargServer GETAPI
getApi = get
data HTML
instance Accept HTML where
contentType _ = "text" // "html" /: ("charset", "utf-8")
instance ToJSON a => MimeRender HTML a where
mimeRender _ = encode
----------------------
type JSONAPI = Summary "Update List"
:> "lists"
......
src/Gargantext/API/Node/DocumentsFromWriteNodes.hs
View file @ ba856c93
......@@ -48,7 +48,6 @@ type API = Summary " Documents from Write nodes."
------------------------------------------------------------------------
newtype Params = Params { id :: Int }
deriving (Generic, Show)
instance FromJSON Params where
parseJSON = genericParseJSON defaultOptions
instance ToJSON Params where
......
src/Gargantext/API/Routes.hs
View file @ ba856c93
......@@ -28,7 +28,7 @@ import Servant.Auth.Swagger ()
import Servant.Job.Async
import Servant.Swagger.UI
import Gargantext.API.Admin.Auth (withAccess)
import Gargantext.API.Admin.Auth (ForgotPasswordAPI, ForgotPasswordAsyncAPI, withAccess)
import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, AuthenticatedUser(..), PathId(..))
import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
import Gargantext.API.Context
......@@ -72,6 +72,8 @@ type GargAPI' =
"auth" :> Summary "AUTH API"
:> ReqBody '[JSON] AuthRequest
:> Post '[JSON] AuthResponse
:<|> "forgot-password" :> ForgotPasswordAPI
:<|> "async" :> "forgot-password" :> ForgotPasswordAsyncAPI
:<|> GargVersion
-- TODO-ACCESS here we want to request a particular header for
-- auth and capabilities.
......
src/Gargantext/API/Server.hs
View file @ ba856c93
......@@ -28,7 +28,7 @@ import qualified Paths_gargantext as PG -- cabal magic build module
import qualified Gargantext.API.Public as Public
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.Auth (auth)
import Gargantext.API.Admin.Auth (auth, forgotPassword, forgotPasswordAsync)
import Gargantext.API.Admin.FrontEnd (frontEndServer)
import qualified Gargantext.API.GraphQL as GraphQL
import Gargantext.API.Prelude
......@@ -44,6 +44,8 @@ import Gargantext.Prelude.Config (gc_url_backend_api)
serverGargAPI :: ToJSON err => Text -> GargServerM env err GargAPI
serverGargAPI baseUrl -- orchestrator
= auth
:<|> forgotPassword
:<|> forgotPasswordAsync
:<|> gargVersion
:<|> serverPrivateGargAPI
:<|> Public.api baseUrl
......
src/Gargantext/API/Types.hs 0 → 100644
View file @ ba856c93
{-# OPTIONS_GHC -fprint-potential-instances #-}
module Gargantext.API.Types where
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BS8
import Data.Either (Either(..))
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Text (Text)
import qualified Data.Text.Encoding as E
import Data.Typeable
import Network.HTTP.Media ((//), (/:))
import Prelude (($))
import qualified Prelude
import Servant
( Accept(..)
, MimeRender(..)
, MimeUnrender(..) )
data HTML deriving (Typeable)
instance Accept HTML where
contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
instance MimeRender HTML BS8.ByteString where
mimeRender _ = Prelude.id
instance MimeUnrender HTML BS8.ByteString where
mimeUnrender _ bs = Right bs
instance MimeRender HTML Text where
mimeRender _ bs = BS8.fromStrict $ E.encodeUtf8 bs
instance MimeUnrender HTML Text where
mimeUnrender _ bs = Right $ E.decodeUtf8 $ BS8.toStrict bs
instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender HTML a where
mimeRender _ = encode
src/Gargantext/Core/Mail.hs
View file @ ba856c93
......@@ -14,6 +14,7 @@ module Gargantext.Core.Mail where
import Control.Lens (view)
import Data.Text (Text, unlines, splitOn)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_url)
import Gargantext.Database.Prelude
......@@ -39,6 +40,7 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
| MailInfo { mailInfo_username :: Name
, mailInfo_address :: EmailAddress
}
| ForgotPassword { user :: UserLight }
------------------------------------------------------------------------
------------------------------------------------------------------------
mail :: (CmdM env err m) => MailConfig -> MailModel -> m ()
......@@ -66,6 +68,7 @@ email_to :: MailModel -> (EmailAddress, Name)
email_to (Invitation user) = email_to' user
email_to (PassUpdate user) = email_to' user
email_to (MailInfo { .. }) = (mailInfo_address, mailInfo_username)
email_to (ForgotPassword { user = UserLight { .. }}) = (userLight_email, userLight_username)
email_to' :: NewUser GargPassword -> (EmailAddress, Name)
email_to' (NewUser u m _) = (m,u)
......@@ -80,12 +83,21 @@ bodyWith server (PassUpdate u) = [ "Your account password have been updated on t
] <> (email_credentials server u)
bodyWith server (MailInfo _ _) = [ "Your last analysis is over on the server: " <> server]
bodyWith _server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Nothing }}) =
[ "Cannot send you link to forgot password, no UUID" ]
bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Just uuid }}) =
[ "Click on this link to restore your password: "
, forgot_password_link server uuid ]
forgot_password_link :: ServerAddress -> Text -> Text
forgot_password_link server uuid = server <> "/api/v1.0/forgot-password?uuid=" <> uuid
------------------------------------------------------------------------
email_subject :: MailModel -> Text
email_subject (Invitation _) = "[GarganText] Invitation"
email_subject (PassUpdate _) = "[GarganText] Update"
email_subject (MailInfo _ _) = "[GarganText] Info"
email_subject (Invitation _) = "[GarganText] Invitation"
email_subject (PassUpdate _) = "[GarganText] Update"
email_subject (MailInfo _ _) = "[GarganText] Info"
email_subject (ForgotPassword _) = "[GarganText] Forgot Password"
email_credentials :: ServerAddress -> NewUser GargPassword -> [Text]
......
src/Gargantext/Core/Utils.hs
View file @ ba856c93
......@@ -16,16 +16,44 @@ module Gargantext.Core.Utils (
-- module Gargantext.Utils.Chronos
module Gargantext.Core.Utils.Prefix
, something
, alphanum
, choices
, randomString
) where
import Data.Char (chr, ord)
import Data.Maybe
import Data.Monoid
import Data.Text (Text, pack)
import Prelude ((!!))
import System.Random (initStdGen, uniformR)
-- import Gargantext.Utils.Chronos
import Gargantext.Core.Utils.Prefix
import Gargantext.Prelude
something :: Monoid a => Maybe a -> a
something Nothing = mempty
something (Just a) = a
alphanum :: [Char]
alphanum = (chr <$> digits) <> (chr <$> lowercase) <> (chr <$> uppercase)
where
digits = [(ord '0')..(ord '9')]
lowercase = [(ord 'a')..(ord 'z')]
uppercase = [(ord 'A')..(ord 'Z')]
choices :: Int -> [a] -> IO [a]
choices 0 _ = pure []
choices num lst = do
gen <- initStdGen
let (cIdx, _) = uniformR (0, length lst - 1) gen
c = lst !! cIdx
choices' <- choices (num - 1) lst
pure (c:choices')
randomString :: Int -> IO Text
randomString num = do
str <- choices num alphanum
pure $ pack str
src/Gargantext/Database/Prelude.hs
View file @ ba856c93
......@@ -16,6 +16,7 @@ module Gargantext.Database.Prelude where
import Control.Exception
import Control.Lens (Getter, view)
import Control.Monad.Except
--import Control.Monad.Logger (MonadLogger)
import Control.Monad.Random
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
......@@ -65,12 +66,14 @@ type CmdM'' env err m =
, MonadError err m
, MonadBaseControl IO m
, MonadRandom m
--, MonadLogger m
)
type CmdM' env err m =
( MonadReader env m
, MonadError err m
, MonadBaseControl IO m
--, MonadLogger m
-- , MonadRandom m
)
......
src/Gargantext/Database/Query/Table/User.hs
View file @ ba856c93
......@@ -27,6 +27,8 @@ module Gargantext.Database.Query.Table.User
, getUsersWithHyperdata
, getUsersWithNodeHyperdata
, updateUserEmail
, updateUserPassword
, updateUserForgotPasswordUUID
, getUser
, insertNewUsers
, selectUsersLightWith
......@@ -34,6 +36,8 @@ module Gargantext.Database.Query.Table.User
, userWithId
, userLightWithId
, getUsersWith
, getUsersWithEmail
, getUsersWithForgotPasswordUUID
, getUsersWithId
, module Gargantext.Database.Schema.User
)
......@@ -41,9 +45,11 @@ module Gargantext.Database.Query.Table.User
import Control.Arrow (returnA)
import Control.Lens ((^.))
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Text (Text)
import Data.Time (UTCTime)
import qualified Data.UUID as UUID
import Gargantext.Core.Types.Individu
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.Database.Admin.Config (nodeTypeId)
......@@ -75,25 +81,34 @@ updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
updateUserQuery :: UserWrite -> Update Int64
updateUserQuery us' = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
-> UserDB _id p' ll su un fn ln em' is ia dj
, uUpdateWith = updateEasy (\ (UserDB { .. })
-> UserDB { user_password = p'
, user_email = em'
, .. }
)
, uWhere = (\row -> user_username row .== un')
, uReturning = rCount
}
where
UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
UserDB { user_password = p'
, user_username = un'
, user_email = em' } = us'
-----------------------------------------------------------------------
toUserWrite :: NewUser HashPassword -> UserWrite
toUserWrite (NewUser u m (Auth.PasswordHash p)) =
UserDB (Nothing) (sqlStrictText p)
(Nothing) (sqlBool True) (sqlStrictText u)
(sqlStrictText "first_name")
(sqlStrictText "last_name")
(sqlStrictText m)
(sqlBool True)
(sqlBool True) Nothing
UserDB { user_id = Nothing
, user_password = sqlStrictText p
, user_lastLogin = Nothing
, user_isSuperUser = sqlBool True
, user_username = sqlStrictText u
, user_firstName = sqlStrictText "first_name"
, user_lastName = sqlStrictText "last_name"
, user_email = sqlStrictText m
, user_isStaff = sqlBool True
, user_isActive = sqlBool True
, user_dateJoined = Nothing
, user_forgot_password_uuid = Nothing }
------------------------------------------------------------------
getUsersWith :: Username -> Cmd err [UserLight]
......@@ -105,6 +120,24 @@ selectUsersLightWith u = proc () -> do
restrict -< user_username row .== sqlStrictText u
returnA -< row
getUsersWithEmail :: Text -> Cmd err [UserLight]
getUsersWithEmail e = map toUserLight <$> runOpaQuery (selectUsersLightWithEmail e)
selectUsersLightWithEmail :: Text -> Select UserRead
selectUsersLightWithEmail e = proc () -> do
row <- queryUserTable -< ()
restrict -< user_email row .== sqlStrictText e
returnA -< row
getUsersWithForgotPasswordUUID :: UUID.UUID -> Cmd err [UserLight]
getUsersWithForgotPasswordUUID uuid = map toUserLight <$> runOpaQuery (selectUsersLightWithForgotPasswordUUID uuid)
selectUsersLightWithForgotPasswordUUID :: UUID.UUID -> Select UserRead
selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
row <- queryUserTable -< ()
restrict -< user_forgot_password_uuid row .== sqlStrictText (UUID.toText uuid)
returnA -< row
----------------------------------------------------------
getUsersWithId :: Int -> Cmd err [UserLight]
getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
......@@ -165,12 +198,30 @@ updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB _id _p _ll _su _un _fn _ln _em _is _ia _dj)
-> UserDB _id _p _ll _su _un _fn _ln (sqlStrictText userLight_email) _is _ia _dj)
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_email = sqlStrictText userLight_email, .. } )
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uReturning = rCount }
updateUserPassword :: UserLight -> Cmd err Int64
updateUserPassword (UserLight { userLight_password = GargPassword password, .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
where
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_password = sqlStrictText password, .. } )
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uReturning = rCount }
updateUserForgotPasswordUUID :: UserLight -> Cmd err Int64
updateUserForgotPasswordUUID (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
where
pass = sqlStrictText $ fromMaybe "" userLight_forgot_password_uuid
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uReturning = rCount }
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
......
src/Gargantext/Database/Schema/User.hs
View file @ ba856c93
......@@ -41,35 +41,45 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Opaleye hiding (FromField)
import Opaleye.Internal.Table (Table(..))
------------------------------------------------------------------------
data UserLight = UserLight { userLight_id :: !Int
, userLight_username :: !Text
, userLight_email :: !Text
, userLight_password :: !GargPassword
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 id p _ _ u _ _ e _ _ _ ) = UserLight id u e (toGargPassword p)
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 UserPoly id pass llogin suser
uname fname lname
mail staff active djoined =
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
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)
......@@ -79,6 +89,7 @@ type UserWrite = UserPoly (Maybe (Column SqlInt4)) (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)
......@@ -86,6 +97,7 @@ type UserRead = UserPoly (Column SqlInt4) (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))
......@@ -93,25 +105,27 @@ type UserReadNull = UserPoly (Column (Nullable SqlInt4)) (Column (Nu
(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
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"
(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"
(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"
}
)
......
stack.yaml
View file @ ba856c93
......@@ -26,7 +26,8 @@ nix:
allow-newer: true
#ghc-options:
ghc-options:
"$everything": -fprint-potential-instances
# "$everything": -haddock
extra-deps:
......@@ -119,6 +120,12 @@ extra-deps:
subdirs:
- packages/base
- monad-logger-aeson-0.2.0.0
# required by monad-logger-aeson
- context-0.2.0.0@sha256:6b643adb4a64fe521873d08df0497f71f88e18b9ecff4b68b4eef938e446cfc9,1886
- random-1.2.1
# Others dependencies (using stack resolver)
- constraints-extras-0.3.1.0@sha256:12016ebb91ad5ed2c82bf7e48c6bd6947d164d33c9dca5ac3965de1bb6c780c0,1777
- KMP-0.2.0.0@sha256:6dfbac03ef00ebd9347234732cb86a40f62ab5a80c0cc6bedb8eb51766f7df28,2562
......
version
View file @ ba856c93
......@@ -17,7 +17,7 @@ vim CHANGELOG.md < /dev/tty
YAML="package.yaml"
CABL="gargantext.cabal"
sed -i "s/version:.*/version: \'$VERSION\'/" $YAML
sed -i "s/version:.*/version: $VERSION/" $CABL
sed -i "s/^version:.*/version: $VERSION/" $CABL
git add -u
git commit -m "[VERSION] +1 to ${VERSION}"
git tag $VERSION
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment