Display Appointment

config/models.persistentmodels

@@ -4,13 +4,22 @@ Contents
   content Textarea
   UniqueContents section
 
+Hist
+  book BookId
+  logtime LocalTime
+  day Day
+  time TimeOfDay
+  tz TimeZone
+  status BookStatus  
+
 Book
   user UserId OnDeleteCascade
   offer OfferId OnDeleteCascade
   role RoleId Maybe OnDeleteCascade
   day Day
   time TimeOfDay
   tz TimeZone
+  status BookStatus
 
 Schedule
   role RoleId OnDeleteCascade

src/Demo/DemoDataEN.hs

@@ -9,8 +9,10 @@ import Text.Hamlet (shamlet)
 import Text.Shakespeare.Text (st)
 import qualified Data.ByteString.Base64 as B64 (decode)
 import Data.Text.Encoding (decodeUtf8)
-import Data.Time.Clock (DiffTime)
+import Data.Time.Calendar (addGregorianYearsClip, addGregorianMonthsClip)
+import Data.Time.Clock (getCurrentTime, UTCTime (utctDay,utctDayTime), addUTCTime, DiffTime)
 import Data.Time.Format (parseTimeM, defaultTimeLocale)
+import Data.Time.LocalTime (timeToTimeOfDay, utc)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import ClassyPrelude.Yesod (ReaderT)
 import Yesod.Form.Fields (Textarea (Textarea))
@@ -35,6 +37,8 @@ import Model
     , StaffPhoto (StaffPhoto, staffPhotoPhoto, staffPhotoMime, staffPhotoStaff)
     , Role (Role, roleStaff, roleService, roleName, roleRating)
     , Contents (Contents, contentsSection, contentsContent)
+    , BookStatus (BookStatusRequest)
+    , Book (Book, bookUser, bookOffer, bookRole, bookDay, bookTime, bookTz, bookStatus)
     )
 import Data.FileEmbed (embedFile)
 import Demo.DemoPhotos
@@ -45,6 +49,8 @@ import Demo.DemoPhotos
 populateEN :: MonadIO m => ReaderT SqlBackend m ()
 populateEN = do
 
+    (now,today,time) <- liftIO $ getCurrentTime >>= \x -> return (x,utctDay x,timeToTimeOfDay (utctDayTime x))
+
     insert_ $ Contents { contentsSection = "CONTACTS"
                        , contentsContent = Textarea [st|
 <h3 style="color:gray">Call Us</h3>
@@ -162,7 +168,7 @@ We will continue to offer the latest treatments, the most innovative techniques
 
     e3 <- insert $ Staff { staffName = "John Johnson"
                          , staffStatus = EmplStatusEmployed
-                         , staffPhone = Just "0491 570 006"
+                        , staffPhone = Just "0491 570 006"
                          , staffMobile = Just "0491 570 156"
                          , staffEmail = Just "[email protected]"
                          , staffUser = Just u3
@@ -312,12 +318,12 @@ We will continue to offer the latest treatments, the most innovative techniques
                                       }
 
     e11 <- insert $ Staff { staffName = "Isabel Hughes"
-                         , staffStatus = EmplStatusDismissed
-                         , staffPhone = Just "0491 570 006"
-                         , staffMobile = Just "0491 570 156"
-                         , staffEmail = Just "[email protected]"
-                         , staffUser = Nothing
-                         }
+                          , staffStatus = EmplStatusDismissed
+                          , staffPhone = Just "0491 570 006"
+                          , staffMobile = Just "0491 570 156"
+                          , staffEmail = Just "[email protected]"
+                          , staffUser = Nothing
+                          }
 
     case B64.decode woman05 of
       Left _ -> return ()
@@ -350,11 +356,11 @@ We will continue to offer the latest treatments, the most innovative techniques
                             , serviceGroup = Just s1
                             }
 
-    insert_ $ Role { roleStaff = e1
-                   , roleService = s11
-                   , roleName = "Makeup artist"
-                   , roleRating = Just 5
-                   }
+    r111 <- insert $ Role { roleStaff = e1
+                          , roleService = s11
+                          , roleName = "Makeup artist"
+                          , roleRating = Just 5
+                          }
 
     insert_ $ Offer { offerService = s11
                         , offerName = "Price"
@@ -378,13 +384,22 @@ We will continue to offer the latest treatments, the most innovative techniques
                             , serviceGroup = Just s1
                             }
 
-    insert_ $ Offer { offerService = s12
-                        , offerName = "Price"
-                        , offerPrice = 28
-                        , offerPrefix = Just "$"
-                        , offerSuffix = Nothing
-                        , offerDescr = Nothing
-                        }
+    o121 <- insert $ Offer { offerService = s12
+                           , offerName = "Price"
+                           , offerPrice = 28
+                           , offerPrefix = Just "$"
+                           , offerSuffix = Nothing
+                           , offerDescr = Nothing
+                           }
+
+    insert_ $ Book { bookOffer = o121
+                   , bookRole = Just r111 
+                   , bookUser = u2
+                   , bookDay = addGregorianMonthsClip 1 today
+                   , bookTime = time
+                   , bookTz = utc
+                   , bookStatus = BookStatusRequest
+                   }
 
     insert_ $ Thumbnail { thumbnailService = s12
                         , thumbnailPhoto = $(embedFile "static/img/women-hair-cuts-above-shoulders.avif")

src/Handler/Account.hs

@@ -35,7 +35,7 @@ import Yesod.Form.Types
     )
 import Yesod.Form
     ( generateFormPost, mreq, textField, mopt
-    , fileField, emailField, runFormPost, checkBoxField
+    , fileField, emailField, runFormPost
     )
 import Yesod.Auth (Route (LoginR, LogoutR), maybeAuth)
 
@@ -46,8 +46,8 @@ import Foundation
       ( MsgAccount, MsgCancel, MsgUsername, MsgPassword
       , MsgPhoto, MsgFullName, MsgEmail, MsgSignUp
       , MsgConfirmPassword, MsgYouMustEnterTwoValues
-      , MsgPasswordsDoNotMatch, MsgRegistration, MsgAdministrator
-      , MsgUserProfile, MsgLogout, MsgLogin, MsgLoginToSeeYourProfile
+      , MsgPasswordsDoNotMatch, MsgRegistration, MsgUserProfile
+      , MsgLogout, MsgLogin, MsgLoginToSeeYourProfile
       )
     )
 
@@ -57,7 +57,7 @@ import Database.Persist (Entity (Entity), insert, insert_)
 
 import Model
     ( ultDestKey
-    , User (userName, User, userPassword, userFullName, userAdmin), UserId
+    , User (userName, User, userPassword, userFullName), UserId
     , UserPhoto (UserPhoto, userPhotoUser, userPhotoPhoto, userPhotoMime)
     , EntityField (UserPhotoUser)
     )
@@ -131,11 +131,6 @@ formAccount user extra = do
         , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing
         , fsAttrs = [("class","mdc-text-field__input")]
         } (userPassword <$> user)
-    (adminR,adminV) <- mreq checkBoxField FieldSettings
-        { fsLabel = SomeMessage MsgAdministrator
-        , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing
-        , fsAttrs = [("class","mdc-checkbox__native-control")]
-        } (userAdmin <$> user)
     (fnameR,fnameV) <- mopt textField FieldSettings
         { fsLabel = SomeMessage MsgFullName
         , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing
@@ -152,7 +147,7 @@ formAccount user extra = do
         , fsAttrs = [("style","display:none")]
         } Nothing
 
-    let r = (,) <$> (User <$> nameR <*> passR <*> adminR <*> fnameR <*> emailR) <*> photoR
+    let r = (,) <$> (User <$> nameR <*> passR <*> FormSuccess False <*> fnameR <*> emailR) <*> photoR
 
     let w = do
             toWidget [julius|
@@ -194,29 +189,6 @@ document.getElementById(#{fvId photoV}).addEventListener('change',function (e) {
     <div.mdc-text-field-helper-line>
       <div.mdc-text-field-helper-text.mdc-text-field-helper-text--validation-msg aria-hidden=true>
         #{err}
-
-<div.mdc-form-field.form-field data-mdc-auto-init=MDCFormField style="display:flex;flex-direction:row">
-  ^{fvInput adminV}
-  $with selected <- resolveSelected adminR
-    <button.mdc-switch type=button role=switch #switchAdmin data-mdc-auto-init=MDCSwitch
-      :selected:.mdc-switch--selected :selected:aria-checked=true
-      :not selected:.mdc-switch--unselected :not selected:aria-checked=false
-      onclick="document.getElementById('#{fvId adminV}').checked = !this.MDCSwitch.selected">
-      <div.mdc-switch__track>
-      <div.mdc-switch__handle-track>
-        <div.mdc-switch__handle>
-          <div.mdc-switch__shadow>
-            <div.mdc-elevation-overlay>
-          <div.mdc-switch__ripple>
-          <div.mdc-switch__icons>
-            <svg.mdc-switch__icon.mdc-switch__icon--on viewBox="0 0 24 24">
-              <path d="M19.69,5.23L8.96,15.96l-4.23-4.23L2.96,13.5l6,6L21.46,7L19.69,5.23z">
-            <svg.mdc-switch__icon.mdc-switch__icon--off viewBox="0 0 24 24">
-              <path d="M20 13H4v-2h16v2z">
-
-    <span.mdc-switch__focus-ring-wrapper>
-      <span.mdc-switch__focus-ring>
-    <label for=switchAdmin>_{MsgAdministrator}
 
 $forall v <- [fnameV,emailV]
   <div.form-field>
@@ -232,8 +204,6 @@ $forall v <- [fnameV,emailV]
           #{errs}
 |]
     return (r, w)
-  where
-      resolveSelected adminR = case adminR of FormSuccess x -> x ; _ -> False
 
 
 passwordConfirmField :: Field Handler Text

src/Handler/Appointments.hs

@@ -1,56 +1,74 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Handler.Appointments
   ( getAppointmentsR
   , getAppointmentR
   ) where
 
+import Data.Text (unpack, intercalate)
+import Data.Time.Format (defaultTimeLocale, formatTime)
 import Text.Hamlet (Html)
+import Text.Shakespeare.I18N (renderMessage)
 
 import Yesod.Auth (maybeAuth, Route (LoginR, LogoutR))
-import Yesod.Core (Yesod(defaultLayout), getMessages)
+import Yesod.Core (Yesod(defaultLayout), getMessages, getYesod, languages)
 import Yesod.Core.Handler (setUltDestCurrent)
 import Yesod.Core.Widget (setTitleI)
 import Yesod.Persist (Entity (Entity), YesodPersist(runDB))
 import Settings (widgetFile)
 
 import Database.Esqueleto.Experimental
-    ( select, from, table, innerJoin, leftJoin, on, where_, val
-    , (:&)((:&)), (^.), (?.), (==.), selectOne, isNothing_
+    ( select, selectOne, from, table, innerJoin, on, where_, val
+    , (:&)((:&)), (^.), (==.), (?.)
+    , orderBy, desc, leftJoin, just
     )
 
 import Foundation
     ( Handler
     , Route
       ( ProfileR, AppointmentsR, AppointmentR, BookOffersR, AuthR
-      , PhotoPlaceholderR, AccountPhotoR
+      , PhotoPlaceholderR, AccountPhotoR, ServiceThumbnailR, AdminR
       )
+    , AdminR (AdmStaffPhotoR)
     , AppMessage
       ( MsgMyAppointments, MsgLogin, MsgLogout, MsgPhoto
       , MsgLoginToSeeYourAppointments, MsgNoAppointmentsYet
       , MsgBookAppointment, MsgAppointment, MsgCancelAppointment
-      , MsgRescheduleAppointment
+      , MsgRescheduleAppointment, MsgSymbolHour, MsgSymbolMinute
+      , MsgThumbnail
       )
     )
 
 import Model
-    ( BookId, Book(Book), Offer (Offer), User (User)
-    , EntityField (BookOffer, OfferId, BookUser, UserId, BookId)
+    ( BookId, Book(Book), Offer (Offer), Service (Service), Role (Role)
+    , EntityField
+      ( BookOffer, OfferId, BookUser, BookId, OfferService, ServiceId
+      , BookDay, BookTime, BookRole, RoleId, RoleStaff, StaffId, ThumbnailService
+      )
+    , Staff (Staff), Thumbnail (Thumbnail)
     )
 
 import Menu (menu)
 
+
 getAppointmentR :: BookId -> Handler Html
 getAppointmentR bid = do
     user <- maybeAuth
     book <- runDB $ selectOne $ do
-        x <- from $ table @Book
+        x :& o :& s :& t :& r :& e <- from $ table @Book
+            `innerJoin` table @Offer `on` (\(x :& o) -> x ^. BookOffer ==. o ^. OfferId)
+            `innerJoin` table @Service `on` (\(_ :& o :& s) -> o ^. OfferService ==. s ^. ServiceId)
+            `leftJoin` table @Thumbnail `on` (\(_ :& _ :& s :& t) -> just (s ^. ServiceId) ==. t ?. ThumbnailService)
+            `leftJoin` table @Role `on` (\(x :& _ :& _ :& _ :& r) -> x ^. BookRole ==. r ?. RoleId)
+            `leftJoin` table @Staff `on` (\(_ :& _ :& _ :& _ :& r :& e) -> r ?. RoleStaff ==. e ?. StaffId)
         where_ $ x ^. BookId ==. val bid
         case user of
           Just (Entity uid _) -> where_ $ x ^. BookUser ==. val uid
           Nothing -> where_ $ val False
-        return x
+        orderBy [desc (x ^. BookDay), desc (x ^. BookTime)]
+        return (x,o,s,t,r,e)
     defaultLayout $ do
         setTitleI MsgAppointment
         $(widgetFile "appointments/appointment")
@@ -66,10 +84,15 @@ getAppointmentsR = do
           setTitleI MsgMyAppointments
           $(widgetFile "appointments/login")
       Just (Entity uid _) -> do
+          app <- getYesod
+          langs <- languages
           books <- runDB $ select $ do
-              x <- from $ table @Book
+              x :& _ :& s <- from $ table @Book
+                  `innerJoin` table @Offer `on` (\(x :& o) -> x ^. BookOffer ==. o ^. OfferId)
+                  `innerJoin` table @Service `on` (\(_ :& o :& s) -> o ^. OfferService ==. s ^. ServiceId)
               where_ $ x ^. BookUser ==. val uid
-              return x
+              orderBy [desc (x ^. BookDay), desc (x ^. BookTime)]
+              return (x,s)
           defaultLayout $ do
               setTitleI MsgMyAppointments
               $(widgetFile "appointments/appointments")

src/Handler/Book.hs

@@ -106,7 +106,7 @@ import Model
       , ServiceName, RoleStaff, RoleRating, RoleService, OfferId, BookOffer
       , BookUser, BookRole, ThumbnailService, ThumbnailAttribution
       , ServiceOverview, ServiceDescr, ServiceGroup
-      )
+      ), BookStatus (BookStatusRequest)
     )
 
 import Menu (menu)
@@ -205,7 +205,7 @@ postBookCustomerR = do
           case fr of
             FormSuccess (items,role,day,time,tz,Entity uid _) -> do
                 bids <- forM items $ \((_,Entity oid _),_) -> runDB $
-                    insert $ Book uid oid ((\(_,Entity rid _) -> rid) <$> role) day time tz
+                    insert $ Book uid oid ((\(_,Entity rid _) -> rid) <$> role) day time tz BookStatusRequest
                 addMessageI "info" MsgRecordAdded
                 deleteSession sessKeyBooking
                 redirect (BookEndR, ("bid",) . pack . show . fromSqlKey <$> bids)

src/Model.hs

@@ -55,6 +55,13 @@ import Database.Persist.Sql (fromSqlKey, toSqlKey, PersistFieldSql, sqlType)
 data ServiceStatus = ServiceStatusPulished | ServiceStatusUnpublished
   deriving (Show, Read, Eq)
 
+data BookStatus = BookStatusRequest
+                | BookStatusConfirmed
+                | BookStatusPaid
+                | BookStatusCancelled
+    deriving (Show, Read, Eq)
+derivePersistField "BookStatus"
+
 data EmplStatus = EmplStatusEmployed | EmplStatusDismissed
     deriving (Show, Read, Eq)
 derivePersistField "EmplStatus"