[FIX] Merge

gargantext.cabal

-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

@@ -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

@@ -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

@@ -106,4 +106,21 @@ instance Arbitrary AuthValid where
                        , u <-  [1..3]
                        ]
 
-data PathId = PathNode NodeId | PathNodeNode ListId DocId
+data PathId = PathNode NodeId | PathNodeNode ListId DocId
\ No newline at end of file
+
+
+---------------------------
+
+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

@@ -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

@@ -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

@@ -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

+{-# 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

+{-# 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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