From 607b9486a81ed6cb65d30227aeecea3412bd1ccd Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 20 Apr 2024 03:18:46 +0200 Subject: restructure: have "tickets" independent of gtfs this is mostly meant to guard against the gtfs changing under tracktrain, and not yet complete (e.g. a ticket does not yet save its expected stops, which it probably should). --- lib/Server/ControlRoom.hs | 224 +++++++++++++++++++++++++++++++--------------- 1 file changed, 151 insertions(+), 73 deletions(-) (limited to 'lib/Server/ControlRoom.hs') diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 773468a..4fb5ba8 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Server.ControlRoom (ControlRoom(..)) where -import Control.Monad (forM_, join) +import Config (ServerConfig (..), UffdConfig (..)) +import Control.Monad (forM, forM_, join) import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A @@ -21,6 +22,7 @@ import Data.List (lookup) import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T @@ -35,9 +37,14 @@ import Database.Persist (Entity (..), delete, entityVal, get, insert, selectList, (==.)) import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) import Fmt ((+|), (|+)) import GHC.Float (int2Double) import GHC.Generics (Generic) +import GTFS +import Numeric (showFFloat) +import Persist import Server.Util (Service, secondsNow) import Text.Blaze.Html (ToMarkup (..)) import Text.Blaze.Internal (MarkupM (Empty)) @@ -46,16 +53,9 @@ import Text.Shakespeare.Text import Yesod import Yesod.Auth import Yesod.Auth.OAuth2.Prelude -import Yesod.Form - -import Config (ServerConfig (..), UffdConfig (..)) -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import GTFS -import Numeric (showFFloat) -import Persist import Yesod.Auth.OpenId (IdentifierType (..), authOpenId) import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Yesod.Form import Yesod.Orphans () @@ -71,15 +71,16 @@ mkYesod "ControlRoom" [parseRoutes| / RootR GET /auth AuthR Auth getAuth /trains TrainsR GET -/train/id/#TripID/#Day TrainViewR GET -/train/map/#TripID/#Day TrainMapViewR GET -/train/announce/#TripID/#Day AnnounceR POST +/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 /token/block/#Token TokenBlock GET /trips TripsViewR GET -/trip/#TripID TripViewR GET +/trip/#TripId TripViewR GET /obu OnboardUnitMenuR GET -/obu/#TripID/#Day OnboardUnitR GET +/obu/#TripId/#Day OnboardUnitR GET |] emptyMarkup :: MarkupM a -> Bool @@ -191,7 +192,17 @@ getTrainsR = do let prevday = (T.pack . iso8601Show . addDays (-1)) day let nextday = (T.pack . iso8601Show . addDays 1) day 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)) + (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips))) defaultLayout $ do [whamlet|

_{MsgTrainsOnDay (iso8601Show day)} @@ -205,38 +216,71 @@ $maybe name <- mdisplayname _{Msgtoday} #{nextday} →
+

_{MsgTickets}
    - $forall trip@Trip{..} <- trips -
  1. _{MsgTrip} #{tripName trip} - : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} - $if null trips + $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets +
  2. _{MsgTrip} #{tripName trip} + : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip} + $if null tickets
  3. (_{MsgNone}) +
    +

    _{MsgAccordingToGtfs} +
    + ^{widget} +