aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/Base.hs4
-rw-r--r--lib/Server/Frontend/OnboardUnit.hs28
-rw-r--r--lib/Server/Frontend/Routes.hs5
-rw-r--r--lib/Server/Frontend/Tickets.hs34
-rw-r--r--lib/Server/GTFS_RT.hs16
-rw-r--r--lib/Server/Ingest.hs43
-rw-r--r--lib/Server/Subscribe.hs6
7 files changed, 68 insertions, 68 deletions
diff --git a/lib/Server/Base.hs b/lib/Server/Base.hs
index 14b77ca..17b5b4a 100644
--- a/lib/Server/Base.hs
+++ b/lib/Server/Base.hs
@@ -4,6 +4,6 @@ module Server.Base (ServerState) where
import Control.Concurrent.STM (TQueue, TVar)
import qualified Data.Map as M
import Data.UUID (UUID)
-import Persist (TrainPing)
+import Persist (Ping)
-type ServerState = TVar (M.Map UUID [TQueue (Maybe TrainPing)])
+type ServerState = TVar (M.Map UUID [TQueue (Maybe Ping)])
diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs
index 6a8fe6e..967cb6c 100644
--- a/lib/Server/Frontend/OnboardUnit.hs
+++ b/lib/Server/Frontend/OnboardUnit.hs
@@ -28,7 +28,7 @@ getOnboardTrackerR = do defaultLayout [whamlet|
<section>
<h2>Tracker
- <strong>Token:</strong> <span id="token">
+ <strong>TrackerId:</strong> <span id="trackerId">
<section>
<h2>Status
<p id="status">_{MsgNone}
@@ -44,7 +44,7 @@ getOnboardTrackerR = do defaultLayout [whamlet|
<script>
- var token = null;
+ var trackerId = null;
let euclid = (a,b) => {
let x = a[0]-b[0];
@@ -127,7 +127,7 @@ getOnboardTrackerR = do defaultLayout [whamlet|
if (ws !== undefined && ws.readyState == 1) {
ws.send(JSON.stringify({
- token: token,
+ trackerId: trackerId,
geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ],
timestamp: (new Date()).toISOString()
}));
@@ -144,28 +144,28 @@ getOnboardTrackerR = do defaultLayout [whamlet|
let urlparams = new URLSearchParams(window.location.search);
- token = urlparams.get("token");
+ trackerId = urlparams.get("trackerId");
- if (token === null) {
- token = await (await fetch("/api/tracker/register/", {
+ if (trackerId === null) {
+ trackerId = await (await fetch("/api/tracker/register/", {
method: "POST",
body: JSON.stringify({agent: "tracktrain-website"}),
headers: {"Content-Type": "application/json"}
})).json();
- if (token.error) {
- alert("could not obtain token: \n" + token.msg);
- setStatus("_{MsgTokenFailed}");
+ if (trackerId.error) {
+ alert("could not obtain trackerId: \n" + trackerId.msg);
+ setStatus("_{MsgTrackerIdFailed}");
} else {
- console.log("got token");
- window.location.search = `?token=${token}`;
+ console.log("got trackerId");
+ window.location.search = `?trackerId=${trackerId}`;
}
}
- console.log(token)
+ console.log(trackerId)
- if (token !== null) {
- document.getElementById("token").innerText = token;
+ if (trackerId !== null) {
+ document.getElementById("trackerId").innerText = trackerId;
openWebsocket();
}
}
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index 9245e6a..75b1bda 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -19,7 +19,7 @@ import Data.Time.Calendar (Day)
import Data.UUID (UUID)
import Database.Persist.Sql (SqlBackend, runSqlPool)
import qualified GTFS
-import Persist (Token)
+import Persist (TrackerId)
import Text.Blaze.Internal (MarkupM (Empty))
import Yesod
import Yesod.Auth
@@ -50,7 +50,7 @@ mkYesodData "Frontend" [parseRoutes|
/spacetime SpaceTimeDiagramR GET
-/token/block/#Token TokenBlock GET
+/trackerId/block/#TrackerId TrackerIdBlock GET
/gtfs/trips GtfsTripsViewR GET
/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
@@ -149,3 +149,4 @@ instance YesodAuth Frontend where
redirect ("/auth/page/uffd/forward" :: Text)
onLogout = do
clearSession
+
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index c542074..fc7d777 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -11,7 +11,7 @@ module Server.Frontend.Tickets
, getTicketMapViewR
, getDelAnnounceR
, postAnnounceR
- , getTokenBlock
+ , getTrackerIdBlock
) where
import Server.Frontend.Routes
@@ -229,9 +229,9 @@ getTicketViewR ticketId = do
pure tracker
lastPing <- runDB $ selectOne do
- trainping <- from $ table @TrainPing
- where_ (trainping ^. TrainPingTicket ==. val (coerce ticketId))
- orderBy [desc (trainping ^. TrainPingTimestamp)]
+ trainping <- from $ table @Ping
+ where_ (trainping ^. PingTicket ==. val (Just (coerce ticketId)))
+ orderBy [desc (trainping ^. PingTimestamp)]
pure trainping
anchors <- runDB $ select do
@@ -244,7 +244,7 @@ getTicketViewR ticketId = do
-- trackers <- runDB $ selectList
-- ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ])
-- [Asc TrackerExpires]
- -- lastPing <- runDB $ selectFirst [ TrainPingTicket ==. coerce ticketId ] [Desc TrainPingTimestamp]
+ -- lastPing <- runDB $ selectFirst [ PingTicket ==. coerce ticketId ] [Desc PingTimestamp]
-- anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
-- <&> nonEmpty . fmap entityVal
@@ -264,11 +264,11 @@ getTicketViewR ticketId = do
<section>
<h2>_{MsgLive}
<p><strong>_{MsgLastPing}: </strong>
- $maybe Entity _ TrainPing{..} <- lastPing
- _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
+ $maybe Entity _ Ping{..} <- lastPing
+ _{MsgPing (latitude pingGeopos) (longitude pingGeopos) pingTimestamp}
(<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
$nothing
- <em>(_{MsgNoTrainPing})
+ <em>(_{MsgNoPing})
<p><strong>_{MsgEstimatedDelay}</strong>:
$maybe history <- anchors
$maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds
@@ -299,9 +299,9 @@ $maybe spaceTime <- spaceTimeMaybe
^{widget}
<button>_{MsgSubmit}
<section>
- <h2>_{MsgTokens}
+ <h2>_{MsgTrackerIds}
<table>
- <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
+ <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgTrackerId}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
$if null trackers
<tr><td></td><td style="text-align:center"><em>(_{MsgNone})
$forall Entity (TrackerKey key) Tracker{..} <- trackers
@@ -310,9 +310,9 @@ $maybe spaceTime <- spaceTimeMaybe
<td title="#{key}">#{key}
<td title="#{trackerExpires}">#{trackerExpires}
$if trackerBlocked
- <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
+ <td title="_{MsgUnblockTrackerId}"><a href="@?{(TrackerIdBlock (TrackerKey key), [("unblock", "true")])}">_{MsgUnblockTrackerId}</a>
$else
- <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
+ <td title="_{MsgBlockTrackerId}"><a href="@{TrackerIdBlock (TrackerKey key)}">_{MsgBlockTrackerId}</a>
|]
where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history
guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
@@ -437,16 +437,16 @@ getDelAnnounceR uuid = do
let (TicketKey ticketId) = announcementTicket
in redirect (TicketViewR ticketId)
-getTokenBlock :: Token -> Handler Html
-getTokenBlock token = do
+getTrackerIdBlock :: TrackerId -> Handler Html
+getTrackerIdBlock trackerId = do
YesodRequest{..} <- getRequest
let blocked = lookup "unblock" reqGetParams /= Just "true"
maybe <- runDB do
update \tracker -> do
set tracker [TrackerBlocked =. val blocked]
- where_ (tracker ^. TrackerId ==. val (TrackerKey token))
- -- Yesod.update (TrackerKey token) [ TrackerBlocked Yesod.=. blocked ]
- get (TrackerKey token)
+ where_ (tracker ^. TrackerId ==. val trackerId)
+ -- Yesod.update (TrackerKey trackerId) [ TrackerBlocked Yesod.=. blocked ]
+ get trackerId
case maybe of
Just r@Tracker{..} -> do
liftIO $ print r
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 6ef6ed2..532af89 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -46,9 +46,9 @@ import GTFS (Depth (..), GTFS (..),
import Persist (Announcement (..),
EntityField (..), Key (..),
Station (..), Stop (..),
- Ticket (..), Token (..),
+ Ticket (..), TrackerId (..),
Tracker (..), TrainAnchor (..),
- TrainPing (..), latitude,
+ Ping (..), latitude,
longitude, runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
@@ -168,7 +168,7 @@ gtfsRealtimeServer settings@ServerConfig{..} gtfs@GTFS{..} dbpool =
-- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now)
-- positions <- forM ticket $ \(Entity key ticket) -> do
- -- selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case
+ -- selectFirst [PingTicket ==. key] [Desc PingTimestamp] >>= \case
-- Nothing -> pure Nothing
-- Just lastPing ->
-- pure (Just $ mkPosition (lastPing, ticket))
@@ -176,8 +176,8 @@ gtfsRealtimeServer settings@ServerConfig{..} gtfs@GTFS{..} dbpool =
pure [] -- (catMaybes positions)
where
- mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity
- mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage
+ mkPosition :: (Entity Ping, Ticket) -> RT.FeedEntity
+ mkPosition (Entity key Ping{..}, Ticket{..}) = defMessage
& RT.id .~ T.pack (show key)
& RT.vehicle .~ (defMessage
& RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing
@@ -186,11 +186,11 @@ gtfsRealtimeServer settings@ServerConfig{..} gtfs@GTFS{..} dbpool =
Just trainset -> Just $ defMessage
& RT.label .~ trainset
& RT.position .~ (defMessage
- & RT.latitude .~ double2Float (latitude trainPingGeopos)
- & RT.longitude .~ double2Float (longitude trainPingGeopos)
+ & RT.latitude .~ double2Float (latitude pingGeopos)
+ & RT.longitude .~ double2Float (longitude pingGeopos)
)
-- TODO: should probably give currentStopSequence/stopId here as well
- & RT.timestamp .~ toStupidTime trainPingTimestamp
+ & RT.timestamp .~ toStupidTime pingTimestamp
)
diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs
index 959a4c6..8ef8082 100644
--- a/lib/Server/Ingest.hs
+++ b/lib/Server/Ingest.hs
@@ -107,11 +107,10 @@ handleTrainPing dbpool subscribers cfg onError ping@SentPing{..} =
Nothing -> runSql dbpool (guessTicketFromPing cfg ping) >>= \case
Just ticketId -> pure ticketId
Nothing -> do
- logWarnN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+
+ logWarnN $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+
" sent a ping, but no trips are running today."
throwError err400
-
runSql dbpool $ insertSentPing subscribers cfg ping tracker ticketId
insertSentPing
@@ -140,9 +139,9 @@ insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId =
maybeReassign <- selectFirst
- [ TrainPingTicket ==. ticketId ]
- [ Desc TrainPingTimestamp ]
- <&> find (\ping -> trainPingSequence (entityVal ping) > trainAnchorSequence anchor)
+ [ PingTicket ==. Just ticketId, PingSequence !=. Nothing ]
+ [ Desc PingTimestamp ]
+ <&> find (\ping -> fromJust (pingSequence (entityVal ping)) > trainAnchorSequence anchor)
>> guessTicketFromPing cfg ping
<&> find (/= ticketId)
@@ -154,19 +153,19 @@ insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId =
case maybeReassign of
Just newTicketId -> do
- update sentPingToken
+ update sentPingTrackerId
[TrackerCurrentTicket =. Just newTicketId ]
- logInfoN $ "tracker "+|UUID.toText (coerce sentPingToken)|+
+ logInfoN $ "tracker "+|UUID.toText (coerce sentPingTrackerId)|+
"has switched direction, and was reassigned to ticket "
+|UUID.toText (coerce newTicketId)|+"."
insertSentPing subscribers cfg ping tracker newTicketId
Nothing -> do
- let trackedPing = TrainPing
- { trainPingToken = sentPingToken
- , trainPingGeopos = sentPingGeopos
- , trainPingTimestamp = sentPingTimestamp
- , trainPingSequence = trainAnchorSequence anchor
- , trainPingTicket = ticketId
+ let trackedPing = Ping
+ { pingTrackerId = sentPingTrackerId
+ , pingGeopos = sentPingGeopos
+ , pingTimestamp = sentPingTimestamp
+ , pingSequence = Just (trainAnchorSequence anchor)
+ , pingTicket = Just ticketId
}
insert trackedPing
@@ -182,11 +181,11 @@ insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId =
& (\(stop, _, _) -> stopSequence stop)
& fromIntegral
when (trainAnchorSequence anchor + 0.1 >= maxSequence) $ do
- update sentPingToken
+ update sentPingTrackerId
[TrackerCurrentTicket =. Nothing]
update ticketId
[TicketCompleted =. True]
- logInfoN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+
+ logInfoN $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+
" has completed ticket "+|UUID.toString (coerce ticketId)|+
" (trip "+|ticketTripName|+")"
@@ -214,9 +213,9 @@ handleWS dbpool subscribers cfg Metrics{..} conn = do
liftIO $ WS.sendClose conn (C8.pack err)
-- TODO: send a close msg (Nothing) to the subscribed queues? decGauge metricsWSGauge
Right ping -> do
- -- if invalid token, send a "polite" close request. Note that the client may
+ -- if invalid trackerId, send a "polite" close request. Note that the client may
-- ignore this and continue sending messages, which will continue to be handled.
- handleTrainPing dbpool subscribers cfg (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case
+ handlePing dbpool subscribers cfg (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case
Just anchor -> liftIO $ WS.sendTextData conn (A.encode anchor)
Nothing -> pure ()
@@ -245,11 +244,11 @@ guessTicketFromPing cfg SentPing{..} = do
in smallestDistance))
logInfoN
- $ "Tracker "+|UUID.toString (coerce sentPingToken)|+
+ $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+
" is now handling ticket "+|UUID.toString (coerce (entityKey closestTicket))|+
" (trip "+|ticketTripName (entityVal closestTicket)|+")."
- update sentPingToken
+ update sentPingTrackerId
[TrackerCurrentTicket =. Just (entityKey closestTicket)]
pure (Just (entityKey closestTicket))
@@ -260,9 +259,9 @@ spaceAndTimeDiff (pos1, time1) (pos2, time2) =
where spaceDistance = euclid pos1 pos2
timeDiff = time1 - time2
--- TODO: proper debug logging for expired tokens
-isTokenValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker)
-isTokenValid dbpool token = runSql dbpool $ get token >>= \case
+-- TODO: proper debug logging for expired trackerIds
+isTrackerIdValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker)
+isTrackerIdValid dbpool trackerId = runSql dbpool $ get trackerId >>= \case
Just tracker | not (trackerBlocked tracker) -> do
ifM (hasExpired (trackerExpires tracker))
(pure Nothing)
diff --git a/lib/Server/Subscribe.hs b/lib/Server/Subscribe.hs
index 8559659..5b0edb5 100644
--- a/lib/Server/Subscribe.hs
+++ b/lib/Server/Subscribe.hs
@@ -37,9 +37,9 @@ handleSubscribe dbpool subscribers (ticketId :: UUID) conn = liftIO $ WS.withPin
-- send most recent ping, if any (so we won't have to wait for movement)
runSqlWithoutLog dbpool (selectOne do
- ping <- from (table @TrainPing)
- where_ (ping ^. TrainPingTicket ==. val (coerce ticketId))
- orderBy [desc (ping ^. TrainPingTimestamp)]
+ ping <- from (table @Ping)
+ where_ (ping ^. PingTicket ==. val (Just (coerce ticketId)))
+ orderBy [desc (ping ^. PingTimestamp)]
pure ping)
<&> fmap entityVal
>>= flip whenJust (WS.sendTextData conn . A.encode)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-16 20:49:58 +0000