{-# 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 /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST /spacetime SpaceTimeDiagramR 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 maybeUffd <- getYesod <&> serverConfigLogin . getSettings case maybeUffd of Nothing -> pure Authorized Just UffdConfig{..} -> maybeAuthId >>= \case Just _ -> pure Authorized Nothing -> pure AuthenticationRequired defaultLayout w = do PageContent{..} <- widgetToPageContent w msgs <- getMessages withUrlRenderer [hamlet| $newline never $doctype 5