aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/ControlRoom.hs224
-rw-r--r--lib/Server/GTFS_RT.hs49
2 files changed, 181 insertions, 92 deletions
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|
<h1> _{MsgTrainsOnDay (iso8601Show day)}
@@ -205,38 +216,71 @@ $maybe name <- mdisplayname
<a href="@{TrainsR}">_{Msgtoday}
<a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
<section>
+ <h2>_{MsgTickets}
<ol>
- $forall trip@Trip{..} <- trips
- <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a>
- : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
- $if null trips
+ $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets
+ <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{tripName trip}</a>
+ : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip}
+ $if null tickets
<li style="text-align: center"><em>(_{MsgNone})
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
|]
-getTrainViewR :: TripID -> Day -> Handler Html
-getTrainViewR trip day = do
+postTicketImportR :: Day -> Handler Html
+postTicketImportR day = do
+ gtfs <- getYesod <&> getGtfs
+ let trips = tripsOnDay gtfs day
+ ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+ case result of
+ FormSuccess selected -> do
+ now <- liftIO getCurrentTime
+ let tickets = flip fmap selected $ \(Trip{..}, day) -> Ticket
+ { ticketTrip = tripTripId, ticketDay = day, ticketImported = now
+ , ticketSchedule_version = Nothing, ticketVehicle = Nothing }
+ runDB $ insertMany tickets
+ redirect (TrainsR, [("day", T.pack (iso8601Show day))])
+ _ -> defaultLayout [whamlet|
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId)
+ >>= \case {Nothing -> notFound; Just a -> pure a}
+
GTFS{..} <- getYesod <&> getGtfs
- (widget, enctype) <- generateFormPost (announceForm day trip)
- case M.lookup trip trips of
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+ case M.lookup ticketTrip trips of
Nothing -> notFound
Just res@Trip{..} -> do
- anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
- tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
- lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
- anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
+ let ticketKey = TicketKey ticketId
+ anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+ trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+ <&> fmap (trackerTicketTracker . entityVal)
+ trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires]
+ lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
+ anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
<&> nonEmpty . fmap entityVal
- nowSeconds <- secondsNow day
+ nowSeconds <- secondsNow ticketDay
defaultLayout $ do
mr <- getMessageRender
- setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
+ setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripId|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
[whamlet|
-<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
+<h1>_{MsgTrip} <a href="@{TripViewR tripTripId}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}</a>
<section>
<h2>_{MsgLive}
<p><strong>_{MsgLastPing}: </strong>
$maybe Entity _ TrainPing{..} <- lastPing
_{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
- (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
+ (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
$nothing
<em>(_{MsgNoTrainPing})
<p><strong>_{MsgEstimatedDelay}</strong>:
@@ -245,7 +289,7 @@ getTrainViewR trip day = do
\ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
$nothing
<em> (_{MsgNone})
- <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
+ <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a>
<section>
<h2>_{MsgStops}
<ol>
@@ -262,21 +306,21 @@ getTrainViewR trip day = do
$if null anns
<li><em>(_{MsgNone})</em>
<h3>_{MsgNewAnnouncement}
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
<section>
<h2>_{MsgTokens}
<table>
<tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
- $if null tokens
+ $if null trackers
<tr><td></td><td style="text-align:center"><em>(_{MsgNone})
- $forall Entity (RunningKey key) Running{..} <- tokens
- <tr :runningBlocked:.blocked>
- <td title="#{runningAgent}">#{runningAgent}
+ $forall Entity (TrackerKey key) Tracker{..} <- trackers
+ <tr :trackerBlocked:.blocked>
+ <td title="#{trackerAgent}">#{trackerAgent}
<td title="#{key}">#{key}
- <td title="#{runningExpires}">#{runningExpires}
- $if runningBlocked
+ <td title="#{trackerExpires}">#{trackerExpires}
+ $if trackerBlocked
<td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
$else
<td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
@@ -285,14 +329,16 @@ getTrainViewR trip day = do
guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
-getTrainMapViewR :: TripID -> Day -> Handler Html
-getTrainMapViewR tripId day = do
+getTrainMapViewR :: UUID -> Handler Html
+getTrainMapViewR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId)
+ >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
GTFS{..} <- getYesod <&> getGtfs
- (widget, enctype) <- generateFormPost (announceForm day tripId)
- case M.lookup tripId trips of
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+ case M.lookup ticketTrip trips of
Nothing -> notFound
Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a>
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a>
<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
crossorigin=""/>
@@ -308,7 +354,7 @@ getTrainMapViewR tripId day = do
attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
}).addTo(map);
- ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripID}/#{day}");
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripId}/#{ticketDay}");
var marker = null;
@@ -336,12 +382,12 @@ getTripsViewR = do
<h1>List of Trips
<section><ul>
$forall trip@Trip{..} <- trips
- <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a>
+ <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a>
: #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
|]
-getTripViewR :: TripID -> Handler Html
+getTripViewR :: TripId -> Handler Html
getTripViewR tripId = do
GTFS{..} <- getYesod <&> getGtfs
case M.lookup tripId trips of
@@ -350,7 +396,7 @@ getTripViewR tripId = do
<h1>_{MsgTrip} #{tripName trip}
<section>
<h2>_{MsgInfo}
- <p><strong>_{MsgtripId}:</strong> #{tripTripID}
+ <p><strong>_{MsgtripId}:</strong> #{tripTripId}
<p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
<p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
<section>
@@ -365,17 +411,17 @@ getTripViewR tripId = do
|]
-postAnnounceR :: TripID -> Day -> Handler Html
-postAnnounceR trip day = do
- ((result, widget), enctype) <- runFormPost (announceForm day trip)
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+ ((result, widget), enctype) <- runFormPost (announceForm ticketId)
case result of
FormSuccess ann -> do
runDB $ insert ann
- redirect (TrainViewR trip day)
+ redirect RootR -- (TicketViewR trip day)
_ -> defaultLayout
[whamlet|
<p>_{MsgInvalidInput}.
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
|]
@@ -389,19 +435,20 @@ getDelAnnounceR uuid = do
case ann of
Nothing -> notFound
Just Announcement{..} ->
- redirect (TrainViewR announcementTrip announcementDay)
+ let (TicketKey ticketId) = announcementTicket
+ in redirect (TicketViewR ticketId)
getTokenBlock :: Token -> Handler Html
getTokenBlock token = do
YesodRequest{..} <- getRequest
let blocked = lookup "unblock" reqGetParams /= Just "true"
maybe <- runDB $ do
- update (RunningKey token) [ RunningBlocked =. blocked ]
- get (RunningKey token)
+ update (TrackerKey token) [ TrackerBlocked =. blocked ]
+ get (TrackerKey token)
case maybe of
- Just r@Running{..} -> do
+ Just r@Tracker{..} -> do
liftIO $ print r
- redirect (TrainViewR runningTrip runningDay)
+ redirect RootR
Nothing -> notFound
getOnboardUnitMenuR :: Handler Html
@@ -416,24 +463,55 @@ getOnboardUnitMenuR = do
_{MsgChooseTrain}
$forall Trip{..} <- trips
<hr>
- <a href="@{OnboardUnitR tripTripID day}">
- #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
+ <a href="@{OnboardUnitR tripTripId day}">
+ #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
|]
-getOnboardUnitR :: TripID -> Day -> Handler Html
+getOnboardUnitR :: TripId -> Day -> Handler Html
getOnboardUnitR tripId day =
defaultLayout $(whamletFile "site/obu.hamlet")
-announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm day tripId = renderDivs $ Announcement
- <$> pure tripId
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+ <$> pure (TicketKey ticketId)
<*> areq textField (fieldSettingsLabel MsgHeader) Nothing
<*> areq textField (fieldSettingsLabel MsgText) Nothing
- <*> pure day
<*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
<*> lift (liftIO getCurrentTime <&> Just)
+
+
+tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget)
+tripImportForm trips extra = do
+ forms <- forM trips $ \(trip, day) -> do
+ (aRes, aView) <- mreq checkBoxField "import" Nothing
+ let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+ pure (trip, day, dings, aView)
+
+ let widget = toWidget [whamlet|
+ #{extra}
+ <ol>
+ $forall (trip@Trip{..}, day, res, view) <- forms
+ <li>
+ ^{fvInput view}
+ <label for="^{fvId view}">
+ _{MsgTrip} #{tripName trip}
+ : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip}
+ |]
+
+ let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) =
+ sequenceA (fmap (\(_,_,res,_) -> res) forms)
+
+ pure (fmap catMaybes a, widget)
+
+
mightbe :: Maybe Text -> Text
mightbe (Just a) = a
mightbe Nothing = ""
+
+headsign :: Trip 'Deep 'Deep -> Text
+headsign (Trip{..} :: Trip Deep Deep) =
+ case tripHeadsign of
+ Just headsign -> headsign
+ Nothing -> stationName (stopStation (V.last tripStops))
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 740f71c..412284f 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DataKinds #-}
module Server.GTFS_RT (gtfsRealtimeServer) where
@@ -30,21 +31,22 @@ import qualified Data.UUID as UUID
import qualified Data.Vector as V
import Database.Persist (Entity (..),
PersistQueryRead (selectFirst),
- selectList, (==.))
+ getJust, selectKeysList,
+ selectList, (<-.), (==.))
import Database.Persist.Postgresql (SqlBackend)
import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
LinearExtrapolator (..))
import GHC.Float (double2Float, int2Double)
import GTFS (Depth (..), GTFS (..),
Seconds (..), Stop (..),
- Trip (..), TripID,
+ Trip (..), TripId,
showTimeWithSeconds, stationId,
toSeconds, toUTC, tripsOnDay)
import Persist (Announcement (..),
EntityField (..), Key (..),
- Running (..), Token (..),
- TrainAnchor (..), TrainPing (..),
- runSql)
+ Ticket (..), Token (..),
+ Tracker (..), TrainAnchor (..),
+ TrainPing (..), runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
import Servant.API ((:<|>) (..))
@@ -70,17 +72,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
where
handleServiceAlerts = runSql dbpool $ do
announcements <- selectList [] []
- defFeedMessage (fmap mkAlert announcements)
+ alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
+ ticket <- getJust announcementTicket
+ pure $ mkAlert uuid announcement ticket
+ defFeedMessage alerts
where
- mkAlert :: Entity Announcement -> RT.FeedEntity
- mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+ mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
+ mkAlert uuid Announcement{..} Ticket{..} =
defMessage
& RT.id .~ UUID.toText uuid
& RT.alert .~ (defMessage
& RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
& RT.informedEntity .~ [ defMessage
- & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
+ & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing
]
& RT.maybe'url .~ fmap (monolingual "de") announcementUrl
& RT.headerText .~ monolingual "de" announcementHeader
@@ -92,7 +97,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
nowSeconds <- secondsNow today
let running = M.toList (tripsOnDay gtfs today)
anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
- entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
+ tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] []
+ entities <- selectList [TrainAnchorTicket <-. tickets] []
case nonEmpty (fmap entityVal entities) of
Nothing -> pure Nothing
Just anchors -> pure $ Just (tripId, trip, anchors)
@@ -138,18 +144,23 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
& RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
handleVehiclePositions = runSql dbpool $ do
- (running :: [Entity Running]) <- selectList [] []
- pings <- forM running $ \(Entity key entity) -> do
- selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
+ (trackers :: [Entity Tracker]) <- selectList [] []
+ pings <- forM trackers $ \(Entity trackerId tracker) -> do
+ selectFirst [TrainPingToken ==. trackerId] [] >>= \case
+ Nothing -> pure Nothing
+ Just ping -> do
+ ticket <- getJust (trainPingTicket (entityVal ping))
+ pure (Just (ping, ticket, tracker))
+
defFeedMessage (mkPosition <$> catMaybes pings)
where
- mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
- mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
+ mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity
+ mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage
& RT.id .~ T.pack (show key)
& RT.vehicle .~ (defMessage
- & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
- & RT.maybe'vehicle .~ case runningVehicle of
+ & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing
+ & RT.maybe'vehicle .~ case ticketVehicle of
Nothing -> Nothing
Just trainset -> Just $ defMessage
& RT.label .~ trainset
@@ -180,7 +191,7 @@ defFeedMessage entities = do
)
& RT.entity .~ entities
-defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
+defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor
defTripDescriptor tripId day starttime = defMessage
& RT.tripId .~ tripId
& RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-03 12:57:41 +0000