From d183c681575c74eb3c3eb9b8ee36f279770d0916 Mon Sep 17 00:00:00 2001 From: ciukstar Date: Thu, 26 Oct 2023 03:51:25 +0300 Subject: [PATCH] Add business calendar --- config/routes.yesodroutes | 1 + messages/en.msg | 9 + messages/fr.msg | 9 + messages/ro.msg | 9 + messages/ru.msg | 9 + src/Admin/Business.hs | 127 ++++++++------- src/Admin/Staff.hs | 16 +- src/Application.hs | 2 +- src/Foundation.hs | 1 + src/Handler/Account.hs | 6 +- .../person_add_FILL0_wght400_GRAD0_opsz24.svg | 1 + .../admin/business/calendar/calendar.cassius | 62 +++++++ .../admin/business/calendar/calendar.hamlet | 154 ++++++++++++++++++ .../admin/business/calendar/calendar.julius | 27 +++ templates/admin/business/hours/create.cassius | 6 - templates/admin/business/hours/edit.cassius | 6 - templates/admin/business/hours/form.cassius | 7 + templates/admin/business/hours/form.hamlet | 48 ++++++ templates/admin/business/hours/hours.cassius | 5 + templates/admin/business/hours/hours.hamlet | 15 ++ templates/default-layout.cassius | 3 + templates/menu.hamlet | 2 +- 22 files changed, 447 insertions(+), 78 deletions(-) create mode 100644 static/img/person_add_FILL0_wght400_GRAD0_opsz24.svg create mode 100644 templates/admin/business/calendar/calendar.cassius create mode 100644 templates/admin/business/calendar/calendar.hamlet create mode 100644 templates/admin/business/calendar/calendar.julius create mode 100644 templates/admin/business/hours/form.cassius create mode 100644 templates/admin/business/hours/form.hamlet diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index e200c84..b062712 100644 --- a/config/routes.yesodroutes +++ b/config/routes.yesodroutes @@ -58,6 +58,7 @@ /form/business/#BusinessId BusinessHoursCreateR GET /delete/business/#BusinessId/hours/#BusinessHoursId BusinessTimeSlotDeleteR POST /business/#BusinessId/hours/#BusinessHoursId BusinessTimeSlotR GET POST + /business/#BusinessId/caledar BusinessCalendarR GET /business/#BusinessId/hours BusinessHoursR GET POST /business/delete BusinessDeleteR POST /business/#BusinessId/edit BusinessEditR GET POST diff --git a/messages/en.msg b/messages/en.msg index 925295c..c7d6b4d 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -1,3 +1,12 @@ +Mon: Mon +Tue: Tue +Wed: Wed +Thu: Thu +Fri: Fri +Sat: Sat +Sun: Sun +List: List +InvalidTimeInterval: Invalid time interval Holiday: Holiday Weekend: Weekend Weekday: Weekday diff --git a/messages/fr.msg b/messages/fr.msg index 786843b..75fa63f 100644 --- a/messages/fr.msg +++ b/messages/fr.msg @@ -1,3 +1,12 @@ +Mon: lun. +Tue: mar. +Wed: mer. +Thu: jeu. +Fri: ven. +Sat: sam. +Sun: dim. +List: Liste +InvalidTimeInterval: Intervalle de temps invalide Holiday: Jour férié Weekend: Jour de congé Weekday: Jour de travail diff --git a/messages/ro.msg b/messages/ro.msg index 6718cc9..6057e12 100644 --- a/messages/ro.msg +++ b/messages/ro.msg @@ -1,3 +1,12 @@ +Mon: lun. +Tue: mar. +Wed: mie. +Thu: joi +Fri: vin. +Sat: sâm. +Sun: dum. +List: Listă +InvalidTimeInterval: Interval de timp nevalid Holiday: Sărbătoare Weekend: Zi liberă Weekday: Zi de lucru diff --git a/messages/ru.msg b/messages/ru.msg index dcd093d..a9b9e28 100644 --- a/messages/ru.msg +++ b/messages/ru.msg @@ -1,3 +1,12 @@ +Mon: пн +Tue: вт +Wed: ср +Thu: чт +Fri: пт +Sat: сб +Sun: вс +List: Список +InvalidTimeInterval: Неверный интервал времени Holiday: Праздник Weekend: Выходной Weekday: Будний день diff --git a/src/Admin/Business.hs b/src/Admin/Business.hs index cf52d14..2ddc23e 100644 --- a/src/Admin/Business.hs +++ b/src/Admin/Business.hs @@ -17,27 +17,40 @@ module Admin.Business , postBusinessTimeSlotDeleteR , getBusinessHoursEditR , postBusinessTimeSlotR + , getBusinessCalendarR ) where import Control.Applicative ((<|>)) import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (first) import Data.Maybe (isNothing, isJust) -import Data.Text (Text, pack, unpack) -import Data.Time.LocalTime (TimeZone(timeZoneMinutes), minutesToTimeZone) +import Data.Text (Text, pack, unpack, intercalate) +import Text.Shakespeare.I18N (renderMessage) +import Data.Time.Clock (getCurrentTime, utctDay, nominalDiffTimeToSeconds) +import Data.Time.Calendar + ( toGregorian, fromGregorian, weekFirstDay, addDays + , DayOfWeek (Monday) + ) +import Data.Time.LocalTime + ( TimeZone(timeZoneMinutes), minutesToTimeZone, TimeOfDay + , diffLocalTime, LocalTime (LocalTime) + ) +import Data.Time.Format (formatTime, defaultTimeLocale) import Text.Hamlet (Html) import Yesod.Auth (maybeAuth, Route (LoginR)) import Yesod.Core ( Yesod(defaultLayout), getMessages, SomeMessage (SomeMessage) , redirect, addMessageI, newIdent ) -import Yesod.Core.Handler (setUltDestCurrent, getCurrentRoute) -import Yesod.Core.Widget (setTitleI, whamlet) +import Yesod.Core.Handler (setUltDestCurrent, getCurrentRoute, getYesod, languages) +import Yesod.Core.Widget (setTitleI) import Yesod.Form.Fields ( textField, emailField, textareaField, intField, dayField, timeField , hiddenField ) -import Yesod.Form.Functions (generateFormPost, mreq, mopt, runFormPost, checkM) +import Yesod.Form.Functions + ( generateFormPost, mreq, mopt, runFormPost, checkM, check ) import Yesod.Form.Types ( MForm, FormResult (FormSuccess) , FieldView (fvLabel, fvInput, fvErrors, fvId) @@ -61,7 +74,7 @@ import Foundation , AdminR ( BusinessR, BusinessCreateR, BusinessEditR, BusinessDeleteR , BusinessHoursR, BusinessHoursCreateR, BusinessTimeSlotR - , BusinessTimeSlotDeleteR, BusinessHoursEditR + , BusinessTimeSlotDeleteR, BusinessHoursEditR, BusinessCalendarR ) , AppMessage ( MsgBusiness, MsgPhoto, MsgNoBusinessYet, MsgTheName, MsgAddress @@ -71,7 +84,9 @@ import Foundation , MsgMinutes, MsgLogin, MsgUserProfile, MsgNavigationMenu, MsgDel, MsgEdit , MsgBack, MsgTheFullName, MsgCurrency, MsgBusinessDays, MsgDetails, MsgDay , MsgNoBusinessScheduleYet, MsgBusinessHours, MsgStartTime, MsgEndTime - , MsgDayType, MsgWeekday, MsgWeekend, MsgHoliday + , MsgDayType, MsgWeekday, MsgWeekend, MsgHoliday, MsgInvalidTimeInterval + , MsgList, MsgCalendar, MsgMon, MsgTue, MsgWed, MsgThu, MsgFri, MsgSat, MsgSun + , MsgSymbolHour, MsgSymbolMinute ) ) @@ -98,6 +113,30 @@ import Settings (widgetFile) import Menu (menu) +getBusinessCalendarR :: BusinessId -> Handler Html +getBusinessCalendarR bid = do + slots <- runDB $ select $ do + x <- from $ table @BusinessHours + orderBy [desc (x ^. BusinessHoursDay), asc (x ^. BusinessHoursOpen)] + return x + app <- getYesod + langs <- languages + user <- maybeAuth + curr <- getCurrentRoute + msgs <- getMessages + fabBusinessHoursCreate <- newIdent + + today <- utctDay <$> liftIO getCurrentTime + let (y,m,_) = toGregorian today + let start = weekFirstDay Monday (fromGregorian y m 1) + let end = addDays 41 start + let cal = [start .. end] + + defaultLayout $ do + setTitleI MsgBusinessDays + $(widgetFile "/admin/business/calendar/calendar") + + postBusinessTimeSlotR :: BusinessId -> BusinessHoursId -> Handler Html postBusinessTimeSlotR bid sid = do ((fr,fw),et) <- runFormPost $ formHours bid Nothing @@ -128,7 +167,7 @@ postBusinessTimeSlotDeleteR bid sid = do runDB $ P.delete sid addMessageI "info" MsgRecordDeleted redirect (AdminR $ BusinessHoursR bid) - + getBusinessTimeSlotR :: BusinessId -> BusinessHoursId -> Handler Html getBusinessTimeSlotR bid sid = do @@ -163,66 +202,30 @@ formHours bid slot extra = do , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing , fsAttrs = [("class","mdc-text-field__input")] } (businessHoursOpen . entityVal <$> slot) - (endR,endV) <- mreq timeField FieldSettings + + (endR,endV) <- mreq (afterTimeField startR) FieldSettings { fsLabel = SomeMessage MsgEndTime , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing , fsAttrs = [("class","mdc-text-field__input")] } (businessHoursClose . entityVal <$> slot) + (typeR,typeV) <- first (read . unpack <$>) <$> mreq hiddenField FieldSettings { fsLabel = SomeMessage MsgDayType , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing, fsAttrs = [] } (pack . show <$> ((businessHoursDayType . entityVal <$> slot) <|> pure Weekday)) let r = BusinessHours bid <$> dayR <*> startR <*> endR <*> typeR - let w = [whamlet| -#{extra} -$forall (v,icon) <- [(dayV,"event"),(startV,"schedule"),(endV,"schedule")] - - - - #{fvLabel v} - ^{fvInput v} - - - - #{pack icon} - - $maybe errs <- fvErrors v - -