Add authorization

config/routes.yesodroutes

@@ -1,14 +1,18 @@
 
 /contact ContactR GET
 
-/search/requests                    RequestsSearchR    GET
-/requests/#BookId/reschedule        RequestRescheduleR GET
-/requests/#BookId/#ServiceId/assign RequestAssignR     POST
-/requests/#BookId/finish            RequestFinishR     POST
-/requests/#BookId/approve           RequestApproveR    POST
-/requests/#BookId/hist              RequestHistR       GET
-/requests/#BookId                   RequestR           GET POST
-/requests                           RequestsR          GET
+/tasks/#UserId/#StaffId/list/#Day/#BookId TaskItemR      GET
+/tasks/#UserId/#StaffId/list/#Day         TasksDayListR  GET
+/tasks/#UserId/#StaffId/calendar/#Month   TasksCalendarR GET
+
+/search/requests/#UserId/#StaffId                    RequestsSearchR    GET
+/requests/#UserId/#StaffId/#BookId/reschedule        RequestRescheduleR GET
+/requests/#UserId/#StaffId/#BookId/#ServiceId/assign RequestAssignR     POST
+/requests/#UserId/#StaffId/#BookId/finish            RequestFinishR     POST
+/requests/#UserId/#StaffId/#BookId/approve           RequestApproveR    POST
+/requests/#UserId/#StaffId/#BookId/hist              RequestHistR       GET
+/requests/#UserId/#StaffId/#BookId                   RequestR           GET POST
+/requests/#UserId/#StaffId          		     RequestsR          GET
 
 
 /bookings/#UserId/list/#Day/#BookId BookingItemR      GET

messages/en.msg

@@ -1,3 +1,6 @@
+LoginAsEmployeeToContinue: Please login as employee to continue
+LoginToContinue: Please login to continue
+AuthenticationRequired: Authentication required
 NoAppointmentsForThisDay: You have no appointments for this day
 Completed: Completed
 Pending: Pending

messages/fr.msg

@@ -1,3 +1,6 @@
+LoginAsEmployeeToContinue: Veuillez vous connecter en tant qu'employé pour continuer
+LoginToContinue: Veuillez vous connecter pour continuer
+AuthenticationRequired: Authentification requise
 NoAppointmentsForThisDay: Vous n'avez pas de rendez-vous pour ce jour
 Completed: Terminée
 Pending: En attente

messages/ro.msg

@@ -1,3 +1,6 @@
+LoginAsEmployeeToContinue: Vă rugăm să vă autentificați ca angajat pentru a continua
+LoginToContinue: Vă rugăm să vă conectați pentru a continua
+AuthenticationRequired: Este necesară autentificarea
 NoAppointmentsForThisDay: Nu aveți programări pentru această zi
 Completed: Finalizată
 Pending: În așteptare

messages/ru.msg

@@ -1,3 +1,6 @@
+LoginAsEmployeeToContinue: Пожалуйста, войдите в систему как сотрудник, чтобы продолжить
+LoginToContinue: Пожалуйста, войдите, чтобы продолжить
+AuthenticationRequired: Необходима аутентификация
 NoAppointmentsForThisDay: У вас нет записи на этот день
 Completed: Выполнена
 Pending: В ожидании

src/Application.hs

@@ -63,6 +63,8 @@ import Handler.Requests
     , getRequestsSearchR, postRequestApproveR
     , postRequestFinishR, postRequestAssignR
     , getRequestRescheduleR, getRequestHistR
+    , getTasksCalendarR, getTasksDayListR
+    , getTaskItemR
     )
 
 import Handler.Appointments

src/Demo/DemoDataEN.hs

@@ -379,7 +379,7 @@ populateEN = do
     pass8 <- liftIO $ makePassword "byoung" 17
     let user8 = User { userName = "byoung"
                      , userPassword = decodeUtf8 pass8
-                     , userAdmin = False
+                     , userAdmin = True
                      , userFullName = Just "Barbara Young"
                      , userEmail = Just "[email protected]"
                      }

src/Demo/DemoDataFR.hs

@@ -379,7 +379,7 @@ populateFR = do
     pass8 <- liftIO $ makePassword "moreaul" 17
     let user8 = User { userName = "moreaul"
                      , userPassword = decodeUtf8 pass8
-                     , userAdmin = False
+                     , userAdmin = True
                      , userFullName = Just "Moreau Lina"
                      , userEmail = Just "[email protected]"
                      }

src/Demo/DemoDataRO.hs

@@ -377,7 +377,7 @@ populateRO = do
     pass8 <- liftIO $ makePassword "marini" 17
     let user8 = User { userName = "marini"
                      , userPassword = decodeUtf8 pass8
-                     , userAdmin = False
+                     , userAdmin = True
                      , userFullName = Just "Marin Ioana"
                      , userEmail = Just "[email protected]"
                      }

src/Demo/DemoDataRU.hs

@@ -372,7 +372,7 @@ populateRU = do
     pass8 <- liftIO $ makePassword "stepanovatn" 17
     let user8 = User { userName = "stepanovatn"
                      , userPassword = decodeUtf8 pass8
-                     , userAdmin = False
+                     , userAdmin = True
                      , userFullName = Just "Степанова Татьяна Николаевна"
                      , userEmail = Just "[email protected]"
                      }

src/Foundation.hs

@@ -37,9 +37,9 @@ import qualified Data.List.Safe as LS
 import Database.Persist.Sql (ConnectionPool, runSqlPool, fromSqlKey)
 import qualified Database.Esqueleto.Experimental as E ((==.), exists)
 import Database.Esqueleto.Experimental
-    ( select, selectOne, from, table, Value (Value), where_
+    ( select, selectOne, from, table, Value (unValue), where_
     , (^.), (:&) ((:&))
-    , just, orderBy, asc, unionAll_, not_, val
+    , just, orderBy, asc, unionAll_, not_, val, isNothing_
     )
 
 -- | The foundation datatype for your application. This can be a good place to
@@ -250,19 +250,23 @@ instance Yesod App where
     isAuthorized (BookingItemR {}) _ = return Authorized
 
 
-    isAuthorized RequestsR _ = return Authorized
-    isAuthorized (RequestR _) _ = return Authorized
-    isAuthorized RequestsSearchR _ = return Authorized
-    isAuthorized (RequestApproveR _) _ = return Authorized
-    isAuthorized (RequestFinishR _) _ = return Authorized
-    isAuthorized (RequestAssignR _ _) _ = return Authorized
-    isAuthorized (RequestRescheduleR _) _ = return Authorized
-    isAuthorized (RequestHistR _) _ = return Authorized
+    isAuthorized (RequestsR {}) _ = isEmployee
+    isAuthorized (RequestR {}) _ = isEmployee
+    isAuthorized (RequestsSearchR {}) _ = isEmployee
+    isAuthorized (RequestApproveR {}) _ = isEmployee
+    isAuthorized (RequestFinishR {}) _ = isEmployee
+    isAuthorized (RequestAssignR {}) _ = isEmployee
+    isAuthorized (RequestRescheduleR {}) _ = isEmployee
+    isAuthorized (RequestHistR {}) _ = isEmployee
+    isAuthorized (TasksCalendarR {}) _ = isEmployee
+    isAuthorized (TasksDayListR {}) _ = isEmployee
+    isAuthorized (TaskItemR {}) _ = isEmployee
+
 
 
     isAuthorized AccountR _ = return Authorized
     isAuthorized (AccountPhotoR _) _ = return Authorized
-    isAuthorized ProfileR _ = return Authorized
+    isAuthorized ProfileR _ = isAuthenticated
 
     isAuthorized ServicesR _ = return Authorized
     isAuthorized (ServiceR _) _ = return Authorized
@@ -360,20 +364,45 @@ instance YesodAuth App where
     renderAuthMessage app (_:xs) = renderAuthMessage app xs
 
 
--- | Access function to determine if a user is logged in.
 isAuthenticated :: Handler AuthResult
 isAuthenticated = do
-    muid <- maybeAuthId
-    return $ case muid of
-        Nothing -> Unauthorized "You must login to access this page"
-        Just _ -> Authorized
+    user <- maybeAuth
+    ult <- getUrlRender >>= \r -> fromMaybe (r HomeR) <$> lookupSession ultDestKey
+    msgs <- getMessages
+    case user of
+        Nothing -> do
+            r <- defaultLayout $(widgetFile "auth/403")
+            sendResponseStatus status403 r
+        Just _ -> return Authorized
+
+
+isEmployee :: Handler AuthResult
+isEmployee = do
+    user <- maybeAuth
+    ult <- getUrlRender >>= \r -> fromMaybe (r HomeR) <$> lookupSession ultDestKey
+    msgs <- getMessages
+    case user of
+      Nothing -> do
+          r <- defaultLayout $(widgetFile "auth/403")
+          sendResponseStatus status403 r
+      Just (Entity uid _) -> do
+          empl <- runDB $ selectOne $ do
+              x <- from $ table @Staff
+              where_ $ not_ $ isNothing_ $ x ^. StaffUser
+              where_ $ x ^. StaffUser E.==. just (val uid)
+              return x
+          case empl of
+            Nothing -> do
+                r <- defaultLayout $(widgetFile "auth/403empl")
+                sendResponseStatus status403 r
+            _ -> return Authorized
 
 
 formLogin :: Route App -> Widget
 formLogin route = do
     ult <- getUrlRender >>= \rndr -> fromMaybe (rndr HomeR) <$>  lookupSession ultDestKey
     msgs <- getMessages
-    users <- liftHandler $ runDB $ select $ do
+    users <- liftHandler $ unval <$> runDB (select $ do
         x :& y <- from $
             do x <- from $ table @User
                where_ $ not_ $ E.exists $ do
@@ -392,12 +421,14 @@ formLogin route = do
                return $ x :& val True
 
         orderBy [asc y, asc (x ^. UserName)]
-        return (x ^. UserId, x ^. UserName, y)
+        return (((x ^. UserId, x ^. UserName), x ^. UserAdmin), y) )
     loginFormWrapper <- newIdent
     loginForm <- newIdent
     pCreateAccount <- newIdent
     dlgSampleCreds <- newIdent
-    $(widgetFile "login")
+    $(widgetFile "auth/form")
+  where
+      unval = (bimap (bimap (bimap unValue unValue) unValue) unValue <$>)
 
 
 instance YesodAuthPersist App

src/Handler/Book.hs

@@ -111,7 +111,7 @@ import Model
       ( StaffId, RoleId, ServiceId, OfferService, ServicePublished, BookId
       , ServiceName, RoleStaff, RoleRating, RoleService, OfferId, BookOffer
       , BookCustomer, ThumbnailService, ThumbnailAttribution, BusinessCurrency
-      , ServiceOverview, ServiceDescr, ServiceGroup, StaffStatus
+      , ServiceOverview, ServiceDescr, ServiceGroup, StaffStatus, OfferPublished
       )
     )
 
@@ -190,6 +190,7 @@ getBookEndR = do
             `innerJoin` table @Offer `on` (\(x :& o) -> x ^. BookOffer ==. o ^. OfferId)
             `innerJoin` table @Service `on` (\(_ :& o :& s) -> o ^. OfferService ==. s ^. ServiceId)
         where_ $ s ^. ServicePublished
+        where_ $ o ^. OfferPublished
         case user of
           Nothing -> where_ $ val False
           Just (Entity uid _) -> where_ $ x ^. BookCustomer ==. val uid
@@ -815,6 +816,7 @@ queryItems categs mq oids = (second (join . unValue) <$>) <$> ( select $ do
         `on` (\(x :& o) -> x ^. ServiceId ==. o ^. OfferService)
         `leftJoin` table @Thumbnail `on` (\(x :& _ :& t) -> just (x ^. ServiceId) ==. t ?. ThumbnailService)
     where_ $ x ^. ServicePublished
+    where_ $ o ^. OfferPublished
     case mq of
       Just q -> where_ $ ( upper_ (x ^. ServiceName) `like` (%) ++. upper_ (val q) ++. (%) )
           ||. ( upper_ (x ^. ServiceOverview) `like` (%) ++. upper_ (just (val q)) ++. (%) )
@@ -836,6 +838,7 @@ queryOffers categs mq oids = (second (join . unValue) <$>) <$> ( select $ do
         `on` (\(x :& o) -> x ^. ServiceId ==. o ^. OfferService)
         `leftJoin` table @Thumbnail `on` (\(x :& _ :& t) -> just (x ^. ServiceId) ==. t ?. ThumbnailService)
     where_ $ x ^. ServicePublished
+    where_ $ o ^. OfferPublished
     case mq of
       Just q -> where_ $ ( upper_ (x ^. ServiceName) `like` (%) ++. upper_ (val q) ++. (%) )
           ||. ( upper_ (x ^. ServiceOverview) `like` (%) ++. upper_ (just (val q)) ++. (%) )