$if emptyMarkup pageTitle Tracktrain $else #{pageTitle} $maybe description <- pageDescription <meta name="description" content="#{description}"> ^{pageHead} <link rel="stylesheet" href="/assets/style.css"> <meta name="viewport" content="width=device-width, initial-scale=1"> <body> $forall (status, msg) <- msgs  ^{pageBody} |] instance RenderMessage Frontend FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist Frontend where type YesodPersistBackend Frontend = SqlBackend runDB action = do pool <- getYesod <&> getPool runSqlPool action pool -- this instance is only slightly cursed (it keeps login information -- as json in a session cookie and hopes nothing will ever go wrong) instance YesodAuth Frontend where type AuthId Frontend = UffdUser authPlugins cr = case config of UffdConfig {..} -> if uffdConfigEnable then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] else [] where config = serverConfigLogin (getSettings cr) maybeAuthId = do e <- lookupSession "json" pure $ case e of Nothing -> Nothing Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) authenticate creds = do forM_ (credsExtra creds) (uncurry setSession) -- extra <- lookupSession "extra" -- pure (Authenticated ( undefined)) e <- lookupSession "json" case e of Nothing -> error "no session information" Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of Nothing -> error "malformed session information" Just user -> pure $ Authenticated user loginDest _ = RootR logoutDest _ = RootR -- hardcode redirecting to uffd directly; showing the normal login -- screen is kinda pointless when there's only one option loginHandler = do redirect ("/auth/page/uffd/forward"

{-# 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 $if emptyMarkup pageTitle Tracktrain $else #{pageTitle} $maybe description <- pageDescription <meta name="description" content="#{description}"> ^{pageHead} <link rel="stylesheet" href="/assets/style.css"> <meta name="viewport" content="width=device-width, initial-scale=1"> <body> $forall (status, msg) <- msgs  ^{pageBody} |] instance RenderMessage Frontend FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist Frontend where type YesodPersistBackend Frontend = SqlBackend runDB action = do pool <- getYesod <&> getPool runSqlPool action pool -- this instance is only slightly cursed (it keeps login information -- as json in a session cookie and hopes nothing will ever go wrong) instance YesodAuth Frontend where type AuthId Frontend = UffdUser authPlugins cr = case config of UffdConfig {..} -> if uffdConfigEnable then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] else [] where config = serverConfigLogin (getSettings cr) maybeAuthId = do e <- lookupSession "json" pure $ case e of Nothing -> Nothing Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) authenticate creds = do forM_ (credsExtra creds) (uncurry setSession) -- extra <- lookupSession "extra" -- pure (Authenticated ( undefined)) e <- lookupSession "json" case e of Nothing -> error "no session information" Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of Nothing -> error "malformed session information" Just user -> pure $ Authenticated user loginDest _ = RootR logoutDest _ = RootR -- hardcode redirecting to uffd directly; showing the normal login -- screen is kinda pointless when there's only one option loginHandler = do redirect ("/auth/page/uffd/forward" :: Text) onLogout = do clearSession