From dc519ae889ab40fe1723cd601c3e79b73bdd2f51 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 8 May 2024 23:34:43 +0200 Subject: restructure: split web frontend into several modules --- lib/Server/Frontend/Routes.hs | 145 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 lib/Server/Frontend/Routes.hs (limited to 'lib/Server/Frontend/Routes.hs') diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs new file mode 100644 index 0000000..2d74338 --- /dev/null +++ b/lib/Server/Frontend/Routes.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Server.Frontend.Routes where + +import Config (ServerConfig (..), UffdConfig (..)) +import Control.Monad (forM_) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LB +import Data.Functor ((<&>)) +import Data.Pool (Pool) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.UUID (UUID) +import Database.Persist.Sql (SqlBackend, runSqlPool) +import qualified GTFS +import Persist (Token) +import Text.Blaze.Internal (MarkupM (Empty)) +import Yesod +import Yesod.Auth +import Yesod.Auth.OAuth2.Prelude +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Yesod.Orphans () + +data Frontend = Frontend + { getGtfs :: GTFS.GTFS + , getPool :: Pool SqlBackend + , getSettings :: ServerConfig + } + +mkMessage "Frontend" "messages" "en" + +mkYesodData "Frontend" [parseRoutes| +/ RootR GET +/auth AuthR Auth getAuth + +/tickets TicketsR GET +/ticket/#UUID TicketViewR GET +/ticket/map/#UUID TicketMapViewR GET +/ticket/announce/#UUID AnnounceR POST +/ticket/del-announce/#UUID DelAnnounceR GET + +/token/block/#Token TokenBlock GET + +/gtfs/trips GtfsTripsViewR GET +/gtfs/trip/#GTFS.TripId GtfsTripViewR GET +/gtfs/import/#Day GtfsTicketImportR POST + +/tracker OnboardTrackerR GET +|] + +emptyMarkup :: MarkupM a -> Bool +emptyMarkup (Empty _) = True +emptyMarkup _ = False + + +instance Yesod Frontend where + authRoute _ = Just $ AuthR LoginR + isAuthorized OnboardTrackerR _ = pure Authorized + isAuthorized (AuthR _) _ = pure Authorized + isAuthorized _ _ = do + UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings + if uffdConfigEnable then maybeAuthId >>= \case + Just _ -> pure Authorized + Nothing -> pure AuthenticationRequired + else pure Authorized + + + defaultLayout w = do + PageContent{..} <- widgetToPageContent w + msgs <- getMessages + + withUrlRenderer [hamlet| + $newline never + $doctype 5 + +
+