Sign in with Google

.gitignore

@@ -23,6 +23,10 @@ salon.cabal
 node_modules/
 package-lock.json
 package.json
+build-demo-en.sh
+build-demo-fr.sh
+build-demo-ro.sh
+build-demo-ru.sh
 deploy-demo-en.sh
 deploy-demo-fr.sh
 deploy-demo-ro.sh

config/models.persistentmodels

@@ -144,9 +144,16 @@ UserPhoto
   mime Text
   UniqueUserPhoto user
 
+UserCred
+  user UserId OnDeleteCascade
+  name Text
+  val Text
+  UniqueUserCred user name
+
 User
   name Text
-  password Text
+  authType AuthenticationType
+  password Text Maybe
   admin Bool
   analyst Bool
   blocked Bool
@@ -156,6 +163,7 @@ User
   UniqueUser name
   deriving Typeable
 
+
 Brand
   business BusinessId OnDeleteCascade
   mark ByteString Maybe

config/routes.yesodroutes

@@ -200,8 +200,8 @@
 /auth   AuthR   Auth   getAuth
 
 /photo-placeholder PhotoPlaceholderR GET
-/favicon.ico FaviconR GET
-/robots.txt RobotsR GET
+/favicon.ico       FaviconR 	     GET
+/robots.txt        RobotsR  	     GET
 
 /manifest.json WebAppManifestR GET
 /sitemap.xml   SitemapR        GET

messages/en.msg

@@ -1,3 +1,4 @@
+SignInWithGoogle: Sign in with Google
 Cleared: Cleared
 InvalidStoreType: Invalid store type
 Initialization: Initialization

messages/fr.msg

@@ -1,3 +1,4 @@
+SignInWithGoogle: Connectez-vous avec Google
 Cleared: Effacé
 InvalidStoreType: Type de stockage invalide
 Initialization: Initialisation

messages/ro.msg

@@ -1,3 +1,4 @@
+SignInWithGoogle: Conectați-vă cu Google
 Cleared: S-a șters
 InvalidStoreType: Tip de stocare nevalid
 Initialization: Inițializare

messages/ru.msg

@@ -1,3 +1,4 @@
+SignInWithGoogle: Войти через Google
 Cleared: Очищено
 InvalidStoreType: Неверный тип хранилища
 Initialization: Инициализация

package.yaml

@@ -64,6 +64,7 @@ dependencies:
 - http-client
 - safe-exceptions
 - HPDF
+- yesod-auth-oauth2
 
 
 # The library contains all of our application code. The executable

src/Admin/Billing.hs

@@ -853,7 +853,7 @@ renderIvoiceHtml :: Maybe (Entity User)
 renderIvoiceHtml customer employee invoice items = [ihamlet|
 <h1>_{MsgAppName}
 <h2>_{MsgInvoice}  
-$maybe Entity _ (User uname _ _ _ _ _ cname cemail) <- customer
+$maybe Entity _ (User uname _ _ _ _ _ _ cname cemail) <- customer
   $maybe Entity _ (Staff ename _ _ _ eemail _) <- employee
     $maybe Entity _ (Invoice _ _ no status day due) <- invoice
       <table cellspacing=0 cellpadding=10 border=0>

src/Admin/Staff.hs

@@ -163,7 +163,7 @@ import Model
     , ServiceId, Service (Service)
     , UserId,  User (User), UserPhoto (UserPhoto)
     , EmplStatus (EmplStatusUnavailable, EmplStatusAvailable)
-    , SortOrder (SortOrderAsc, SortOrderDesc)
+    , SortOrder (SortOrderAsc, SortOrderDesc), AuthenticationType (UserAuthTypePassword)
     )
 
 import Settings.StaticFiles (img_add_photo_alternate_FILL0_wght400_GRAD0_opsz48_svg)
@@ -663,7 +663,10 @@ formUser empl extra = do
         , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing
         , fsAttrs = [("class","mdc-text-field__input")]
         } (staffEmail . entityVal <$> empl)
-    let r = User <$> nameR <*> passR <*> adminR <*> analystR <*> blockedR <*> deletedR <*> fnameR <*> emailR
+
+    let r = User <$> nameR <*> pure UserAuthTypePassword <*> (pure <$> passR) <*> adminR
+            <*> analystR <*> blockedR <*> deletedR <*> fnameR <*> emailR
+
     let w = [whamlet|
 #{extra}
 $forall v <- [nameV,passV]

src/Admin/Users.hs

@@ -82,16 +82,16 @@ import Foundation
 import Model
     ( UserId
     , User
-      ( User, userName, userPassword, userFullName, userEmail, userAdmin
+      ( User, userName, userFullName, userEmail, userAdmin
       , userAnalyst, userBlocked, userRemoved
       )
     , UserPhoto (UserPhoto)
     , EntityField
       ( UserId, UserName, UserFullName, UserEmail, UserPhotoPhoto
       , UserPhotoMime, UserPassword, UserAdmin, StaffUser, UserAnalyst
-      , UserBlocked, UserRemoved
+      , UserBlocked, UserRemoved, UserAuthType
       )
-    , Staff
+    , Staff, AuthenticationType (UserAuthTypePassword)
     )
 
 import Settings.StaticFiles (img_add_photo_alternate_FILL0_wght400_GRAD0_opsz48_svg)
@@ -177,7 +177,7 @@ postUserPwdResetR uid = do
       FormSuccess (r,_) -> do
           pwd <- liftIO $ decodeUtf8 <$> makePassword (encodeUtf8 r) 17
           runDB $ update $ \x -> do
-              set x [UserPassword =. val pwd]
+              set x [UserPassword =. val (pure pwd)]
               where_ $ x ^. UserId ==. val uid
           addMessageI "info" MsgPasswordChanged
           redirect $ AdminR $ UserR uid
@@ -233,7 +233,7 @@ $case r
               <i.material-symbols-outlined>close            
   $of _
 
-$maybe Entity uid (User name _ _ _ _ _ _ _) <- user
+$maybe Entity uid (User name _ _ _ _ _ _ _ _) <- user
   <figure>
     <img src=@{AccountPhotoR uid} width=56 heigt=56 alt=_{MsgPhoto}>
     <figcaption>
@@ -286,9 +286,10 @@ postUserR uid = do
         return x
     ((fr,fw),et) <- runFormPost $ formUserEdit user
     case fr of
-      FormSuccess (User name _ admin analyst blocked removed fname email,mfi) -> do
+      FormSuccess (User name auth _ admin analyst blocked removed fname email,mfi) -> do
           runDB $ update $ \x -> do
               set x [ UserName =. val name
+                    , UserAuthType =. val auth
                     , UserAdmin =. val admin
                     , UserAnalyst =. val analyst
                     , UserBlocked =. val blocked
@@ -328,8 +329,8 @@ postUsersR :: Handler Html
 postUsersR = do
     ((fr,fw),et) <- runFormPost formUserCreate
     case fr of
-      FormSuccess (r,mfi) -> do
-          uid <- setPassword (userPassword r) r >>= \u -> runDB $ insert u
+      FormSuccess (r@(User _ _ (Just pass) _ _ _ _ _ _),mfi) -> do
+          uid <- setPassword pass r >>= \u -> runDB $ insert u
           addMessageI "info" MsgRecordAdded
           case mfi of
             Just fi -> do
@@ -413,7 +414,7 @@ formUserCreate extra = do
         } Nothing
 
     let r = (,)
-            <$> ( User <$> nameR <*> passR
+            <$> ( User <$> nameR <*> pure UserAuthTypePassword <*> (pure <$> passR)
                   <*> adminR <*> analystR <*> blockedR <*> removedR
                   <*> fnameR <*> emailR
                 ) <*> photoR
@@ -539,7 +540,7 @@ formUserEdit user extra = do
         } Nothing
 
     let r = (,)
-            <$> ( User <$> nameR <*> FormSuccess "Nothing"
+            <$> ( User <$> nameR <*> pure UserAuthTypePassword <*> pure (pure "NOTHING")
                   <*> adminR <*> analystR <*> blockedR <*> removedR
                   <*> fnameR <*> emailR
                 )

src/Demo/DemoDataEN.hs

@@ -29,7 +29,7 @@ import Database.Persist ( PersistStoreWrite(insert_, insert) )
 import Model
     ( User
       ( User, userName, userPassword, userAdmin, userAnalyst, userBlocked
-      , userRemoved, userEmail, userFullName
+      , userRemoved, userEmail, userFullName, userAuthType
       )
     , UserPhoto (UserPhoto, userPhotoUser, userPhotoPhoto, userPhotoMime)
     , Service
@@ -75,7 +75,7 @@ import Model
       ( ContactUs, contactUsBusiness, contactUsShowSchedule, contactUsShowMap
       , contactUsLongitude, contactUsLatitude, contactUsHtml, contactUsShowAddress
       )
-    , DayType (Weekday), PayMethod (PayAtVenue)
+    , DayType (Weekday), PayMethod (PayAtVenue), AuthenticationType (UserAuthTypePassword)
     )
 
 import Data.FileEmbed (embedFile)
@@ -169,7 +169,8 @@ populateEN = do
 
     pass0 <- liftIO $ makePassword "root" 17
     insert_ $ User { userName = "root"
-                   , userPassword = decodeUtf8 pass0
+                   , userAuthType = UserAuthTypePassword
+                   , userPassword = pure $ decodeUtf8 pass0
                    , userAdmin = True
                    , userAnalyst = True
                    , userBlocked = False
@@ -180,7 +181,8 @@ populateEN = do
 
     pass1 <- liftIO $ makePassword "johnnysmith" 17
     let user1 = User { userName = "johnnysmith"
-                     , userPassword = decodeUtf8 pass1
+                     , userAuthType = UserAuthTypePassword
+                     , userPassword = pure $ decodeUtf8 pass1
                      , userAdmin = False
                      , userAnalyst = True
                      , userBlocked = False
@@ -239,7 +241,8 @@ populateEN = do
 
     pass2 <- liftIO $ makePassword "marylopez" 17
     let user2 = User { userName = "marylopez"
-                     , userPassword = decodeUtf8 pass2
+                     , userAuthType = UserAuthTypePassword
+                     , userPassword = pure $ decodeUtf8 pass2
                      , userAdmin = True
                      , userAnalyst = False
                      , userBlocked = False
@@ -271,7 +274,8 @@ populateEN = do
 
     pass3 <- liftIO $ makePassword "johnjohnson" 17
     let user3 = User { userName = "johnjohnson"
-                     , userPassword = decodeUtf8 pass3
+                     , userAuthType = UserAuthTypePassword
+                     , userPassword = pure $ decodeUtf8 pass3
                      , userAdmin = False
                      , userAnalyst = False
                      , userBlocked = False
@@ -304,7 +308,8 @@ populateEN = do
 
     pass4 <- liftIO $ makePassword "patriciabrown" 17
     let user4 = User { userName = "patriciabrown"
-                     , userPassword = decodeUtf8 pass4
+                     , userAuthType = UserAuthTypePassword
+                     , userPassword = pure $ decodeUtf8 pass4
                      , userAdmin = False
                      , userAnalyst = False
                      , userBlocked = False
@@ -337,7 +342,8 @@ populateEN = do
 
     pass5 <- liftIO $ makePassword "chriswilson" 17
     let user5 = User { userName = "chriswilson"
-                     , userPassword = decodeUtf8 pass5
+                     , userAuthType = UserAuthTypePassword
+                     , userPassword = pure $ decodeUtf8 pass5
                      , userAdmin = False
                      , userAnalyst = False
                      , userBlocked = False
@@ -399,7 +405,8 @@ populateEN = do
 
     pass8 <- liftIO $ makePassword "byoung" 17
     let user8 = User { userName = "byoung"
-                     , userPassword = decodeUtf8 pass8
+                     , userAuthType = UserAuthTypePassword
+                     , userPassword = pure $ decodeUtf8 pass8
                      , userAdmin = True
                      , userAnalyst = True
                      , userBlocked = False
@@ -501,7 +508,8 @@ populateEN = do
 
     pass11 <- liftIO $ makePassword "ihughes" 17
     let user11 = User { userName = "ihughes"
-                      , userPassword = decodeUtf8 pass11
+                      , userAuthType = UserAuthTypePassword
+                      , userPassword = pure $ decodeUtf8 pass11
                       , userAdmin = False
                       , userAnalyst = False
                       , userBlocked = False
@@ -3021,7 +3029,8 @@ Body Shaping: Abdomen & waist, hips & thighs, legs & arms
 
     pass6 <- liftIO $ makePassword "pattyofurniture" 17
     c1 <- insert $ User { userName = "pattyofurniture"
-                        , userPassword = decodeUtf8 pass6
+                        , userAuthType = UserAuthTypePassword
+                        , userPassword = pure $ decodeUtf8 pass6
                         , userAdmin = False
                         , userAnalyst = False
                         , userBlocked = False
@@ -3065,7 +3074,8 @@ Body Shaping: Abdomen & waist, hips & thighs, legs & arms
 
     pass7 <- liftIO $ makePassword "raysin" 17
     c2 <- insert $ User { userName = "raysin"
-                        , userPassword = decodeUtf8 pass7
+                        , userAuthType = UserAuthTypePassword
+                        , userPassword = pure $ decodeUtf8 pass7
                         , userAdmin = False
                         , userAnalyst = False
                         , userBlocked = False