From d4f4208fe66d3813b65312dac0bf895c4cdc53d6 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 24 Apr 2024 21:52:45 +0200 Subject: restructure: save a ticket's stop in the database now mostly independent of the gtfs, but still no live-reloading of it. --- lib/Server/ControlRoom.hs | 274 +++++++++++++++++++++++++++++----------------- lib/Server/GTFS_RT.hs | 115 ++++++++++--------- 2 files changed, 234 insertions(+), 155 deletions(-) (limited to 'lib/Server') diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 4fb5ba8..e89b184 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -17,12 +17,13 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LB +import Data.Function (on, (&)) import Data.Functor ((<&>)) -import Data.List (lookup) +import Data.List (lookup, nubBy) import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust) +import Data.Maybe (catMaybes, fromJust, isJust) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T @@ -42,7 +43,7 @@ import Extrapolation (Extrapolator (..), import Fmt ((+|), (|+)) import GHC.Float (int2Double) import GHC.Generics (Generic) -import GTFS +import qualified GTFS import Numeric (showFFloat) import Persist import Server.Util (Service, secondsNow) @@ -60,7 +61,7 @@ import Yesod.Orphans () data ControlRoom = ControlRoom - { getGtfs :: GTFS + { getGtfs :: GTFS.GTFS , getPool :: Pool SqlBackend , getSettings :: ServerConfig } @@ -70,17 +71,21 @@ mkMessage "ControlRoom" "messages" "en" mkYesod "ControlRoom" [parseRoutes| / RootR GET /auth AuthR Auth getAuth -/trains TrainsR GET -/train/id/#UUID TicketViewR GET -/train/import/#Day TicketImportR POST -/train/map/#UUID TrainMapViewR GET -/train/announce/#UUID AnnounceR POST -/train/del-announce/#UUID DelAnnounceR GET + +/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 -/trips TripsViewR GET -/trip/#TripId TripViewR GET + +/gtfs/trips GtfsTripsViewR GET +/gtfs/trip/#GTFS.TripId GtfsTripViewR GET +/gtfs/import/#Day GtfsTicketImportR POST + /obu OnboardUnitMenuR GET -/obu/#TripId/#Day OnboardUnitR GET +/obu/#UUID OnboardUnitR GET |] emptyMarkup :: MarkupM a -> Bool @@ -90,10 +95,10 @@ emptyMarkup _ = False instance Yesod ControlRoom where authRoute _ = Just $ AuthR LoginR isAuthorized OnboardUnitMenuR _ = pure Authorized - isAuthorized (OnboardUnitR _ _) _ = pure Authorized + isAuthorized (OnboardUnitR _) _ = pure Authorized isAuthorized (AuthR _) _ = pure Authorized isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin + UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings if uffdConfigEnable then maybeAuthId >>= \case Just _ -> pure Authorized Nothing -> pure AuthenticationRequired @@ -176,10 +181,10 @@ instance YesodAuth ControlRoom where getRootR :: Handler Html -getRootR = redirect TrainsR +getRootR = redirect TicketsR -getTrainsR :: Handler Html -getTrainsR = do +getTicketsR :: Handler Html +getTicketsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) mdisplayname <- maybeAuthId <&> fmap uffdDisplayName @@ -194,14 +199,13 @@ getTrainsR = do gtfs <- getYesod <&> getGtfs -- TODO: tickets should have all trip information saved - tickets <- runDB $ selectList [ TicketDay ==. day ] [] - <&> fmap (\(Entity (TicketKey ticketId) ticket) -> - (ticketId, ticket, fromJust $ M.lookup (ticketTrip ticket) (trips gtfs))) - - let trips = tripsOnDay gtfs day - let headsign (Trip{..} :: Trip Deep Deep) = case tripHeadsign of - Just headsign -> headsign - Nothing -> stationName (stopStation (V.last tripStops)) + tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do + stops <- selectList [ StopTicket ==. entityKey ticket ] [] + startStation <- getJust (stopStation $ entityVal $ head stops) + pure (ticket, startStation, fmap entityVal stops)) + + let trips = GTFS.tripsOnDay gtfs day + (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips))) defaultLayout $ do [whamlet| @@ -209,77 +213,130 @@ getTrainsR = do $maybe name <- mdisplayname

_{MsgLoggedInAs name} - _{MsgLogout}