[auth] forgot password endpoint first working version

src/Gargantext/API/Admin/Auth.hs

@@ -32,23 +32,28 @@ module Gargantext.API.Admin.Auth
   )
   where
 
-import Control.Lens (view)
+import Control.Lens (view, (#))
 import Data.Text (Text)
 import Data.Text.Lazy (toStrict)
 import qualified Data.Text.Lazy.Encoding as LE
-import Data.UUID (UUID, toText)
+import Data.UUID (UUID, fromText, toText)
 import Data.UUID.V4 (nextRandom)
 import Servant
 import Servant.Auth.Server
+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.Types
-import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer)
+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.Admin.Types.Node (NodeId(..), UserId)
 import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
 import Gargantext.Database.Query.Table.User
@@ -167,23 +172,60 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
   -- users' emails
   pure $ ForgotPasswordResponse "ok"
 
-forgotPasswordGet :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+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) = pure uuid
+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 :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
      => UserLight -> Cmd' env err ()
-forgotUserPassword user@(UserLight { .. }) = do
+forgotUserPassword (UserLight { .. }) = do
   printDebug "[forgotUserPassword] userLight_id" userLight_id
   -- generate uuid for email
   uuid <- generateForgotPasswordUUID
 
-  -- save user with that uuid
-  _ <- updateUserForgotPasswordUUID user uuid
-
   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 })

src/Gargantext/API/Types.hs

@@ -3,19 +3,30 @@
 module Gargantext.API.Types where
 
 import Data.Aeson
-import Data.ByteString.Lazy.Char8 (ByteString)
+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(..) )
+  , MimeRender(..)
+  , MimeUnrender(..) )
 
 data HTML deriving (Typeable)
 instance Accept HTML where
   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
-instance MimeRender HTML ByteString where
+instance MimeRender HTML BS8.ByteString where
   mimeRender _ = Prelude.id
-instance ToJSON a => MimeRender HTML a where
+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

@@ -90,13 +90,13 @@ bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_u
   , forgot_password_link server uuid ]
 
 forgot_password_link :: ServerAddress -> Text -> Text
-forgot_password_link server uuid = server <> "/forgot-password?uuid=" <> uuid
+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"
 
 

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/Query/Table/User.hs

@@ -27,6 +27,7 @@ module Gargantext.Database.Query.Table.User
   , getUsersWithHyperdata
   , getUsersWithNodeHyperdata
   , updateUserEmail
+  , updateUserPassword
   , updateUserForgotPasswordUUID
   , getUser
   , insertNewUsers
@@ -44,6 +45,7 @@ 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)
@@ -200,14 +202,24 @@ updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
       , 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 -> UUID.UUID -> Cmd err Int64
-updateUserForgotPasswordUUID (UserLight { .. }) uuid = mkCmd $ \c -> runUpdate_ c updateUserQuery
+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 = sqlStrictText $ UUID.toText uuid, .. })
+      , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
       , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
       , uReturning  = rCount }
 ------------------------------------------------------------------

src/Gargantext/Database/Schema/User.hs

@@ -47,7 +47,6 @@ data UserLight = UserLight { userLight_id                   :: !Int
                            , userLight_password             :: !GargPassword
                            , userLight_forgot_password_uuid :: !(Maybe Text)
                            } deriving (Show, Generic)
-
 instance GQLType UserLight where
   typeOptions _ = GAGU.unPrefix "userLight_"
 

stack.yaml

@@ -120,6 +120,8 @@ extra-deps:
   subdirs:
     - packages/base
 
+- 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