diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 23 | ||||
| -rw-r--r-- | lib/Config.hs | 5 | ||||
| -rw-r--r-- | lib/Extrapolation.hs | 2 | ||||
| -rw-r--r-- | lib/Persist.hs | 57 | ||||
| -rw-r--r-- | lib/Server/Base.hs | 4 | ||||
| -rw-r--r-- | lib/Server/Frontend/OnboardUnit.hs | 28 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 5 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 34 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 16 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 43 | ||||
| -rw-r--r-- | lib/Server/Subscribe.hs | 6 | ||||
| -rw-r--r-- | lib/Yesod/Orphans.hs | 11 |
12 files changed, 129 insertions, 105 deletions
@@ -54,7 +54,7 @@ import Servant.API.ContentTypes (Accept (..)) -- | a bare ping as sent by a tracker device data SentPing = SentPing - { sentPingToken :: TrackerId + { sentPingTrackerId :: TrackerId , sentPingGeopos :: Geopos , sentPingTimestamp :: UTCTime } deriving (Generic) @@ -66,24 +66,25 @@ instance FromJSON SentPing where type API = -- ingress API (put this behind BasicAuth?) -- TODO: perhaps require a first ping for registration? - "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token + "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] TrackerId :<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor) :<|> "tracker" :> "ping" :> "ws" :> WebSocket :<|> "ticker" :> "current" :> Get '[JSON] Value :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket - :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing]) - :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing] + :<|> "debug" :> "pings" :> Get '[JSON] (Map UUID [Ping]) + :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [Ping] :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile :<|> "gtfs" :> GtfsRealtimeAPI -type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage - :<|> "tripupdates" :> Get '[Proto] FeedMessage - :<|> "vehiclepositions" :> Get '[Proto] FeedMessage +type GtfsRealtimeAPI = "servicealerts" :> QueryFlag "force" :> Get '[Proto] FeedMessage + :<|> "tripupdates" :> QueryFlag "force" :> Get '[Proto] FeedMessage + :<|> "vehiclepositions" :> QueryFlag "force" :> Get '[Proto] FeedMessage + type CompleteAPI = - "api" :> "openapi" :> Get '[JSON] Swagger - :<|> "api" :> API + {- "api" :> "openapi" :> Get '[JSON] Swagger + :<|> -} "api" :> "v1" :> API :<|> "metrics" :> Get '[PlainText] Text :<|> "assets" :> Raw :<|> Raw -- hook for yesod frontend @@ -107,7 +108,7 @@ instance ToSchema Value where declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty & type_ ?~ SwaggerObject instance ToSchema SentPing where - declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "ping") @@ -117,7 +118,7 @@ instance HasSwagger WebSocket where { _swaggerPaths = singleton "/" $ mempty { _pathItemGet = Just $ mempty { _operationSummary = Just "this is a websocket endpoint!" - , _operationDescription = Just "this is a websocket endpoint meant for continious operations, e.g. sending many trainPings one after the other. Unfortunately OpenAPI 2.0 is not suitable to thoroughly model it (hence this text)." + , _operationDescription = Just "this is a websocket endpoint meant for continious operations, e.g. sending many pings one after the other. Unfortunately OpenAPI 2.0 is not suitable to thoroughly model it (hence this text)." , _operationSchemes = Just [ Wss ] , _operationConsumes = Just $ MimeList [ "application/json" ] , _operationProduces = Just $ MimeList [ "application/json" ] diff --git a/lib/Config.hs b/lib/Config.hs index 88206f1..c7fd4e4 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -35,6 +35,7 @@ data ServerConfig = ServerConfig , serverConfigDebugMode :: Bool , serverConfigLogin :: Maybe UffdConfig , serverConfigLogging :: LoggingConfig + , serverConfigBeSilent :: Bool } deriving (Generic) data LoggingConfig = LoggingConfig @@ -62,7 +63,7 @@ instance Config UffdConfig where instance Config LoggingConfig where readConfig = LoggingConfig - <$> readOptionalValue [key|ntfyToken|] + <$> readOptionalValue [key|ntfyTrackerId|] <*> readValue "tracktrain" [key|ntfyTopic|] <*> readValue "tracktrain" [key|name|] @@ -108,4 +109,4 @@ instance Config ServerConfig where <*> readValue False [key|debugmode|] <*> readNestedOptional [key|login|] <*> readNested [key|logging|] - + <*> readValue False [key|beSilent|] diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 759b31e..071e5fa 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -29,7 +29,7 @@ import Persist (Geopos (..), ShapePoint (shapePointGeopos), Station (..), Stop (..), Ticket (..), TicketId, - Token (..), Tracker (..), + TrackerId (..), Tracker (..), TrainAnchor (..)) import Server.Util (utcToSeconds) diff --git a/lib/Persist.hs b/lib/Persist.hs index 637155a..405e815 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -10,7 +10,7 @@ -- also a few little convenience functions for using persistent. module Persist where -import Data.Aeson (FromJSON, ToJSON, ToJSONKey) +import Data.Aeson (FromJSON, ToJSON, ToJSONKey, Value) import Data.Swagger (ToParamSchema (..), ToSchema (..), genericDeclareNamedSchema) import Data.Text (Text) @@ -50,17 +50,18 @@ import MultiLangText (MultiLangText) import Server.Util (runLogging) import Web.PathPieces (PathPiece) import Yesod (Lang) +import qualified OwnTracks -newtype Token = Token UUID - deriving newtype - ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData - , ToJSONKey, PersistField, PersistFieldSql, PathPiece - , ToHttpApiData, Read ) -instance ToSchema Token where - declareNamedSchema _ = declareNamedSchema (Proxy @String) -instance ToParamSchema Token where - toParamSchema _ = toParamSchema (Proxy @String) +-- newtype TrackerId = TrackerId UUID +-- deriving newtype +-- ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData +-- , ToJSONKey, PersistField, PersistFieldSql, PathPiece +-- , ToHttpApiData, Read ) +-- instance ToSchema TrackerId where +-- declareNamedSchema _ = declareNamedSchema (Proxy @String) +-- instance ToParamSchema TrackerId where +-- toParamSchema _ = toParamSchema (Proxy @String) deriving newtype instance PersistField GTFS.Seconds deriving newtype instance PersistFieldSql GTFS.Seconds @@ -86,6 +87,13 @@ latitude = fst . unGeoPos longitude :: Geopos -> Double longitude = snd . unGeoPos +-- TODO: this is horrible. make a custom status msg type instead? +derivePersistFieldJSON "Value" + +-- We derive these here so that OwnTracks.* can become its own package eventually +derivePersistFieldJSON "OwnTracks.Status" + + share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Ticket sql=tt_ticket Id UUID default=uuid_generate_v4() @@ -121,27 +129,37 @@ ShapePoint sql=tt_shape_point Shape sql=tt_shape --- | tokens which have been issued -Tracker sql=tt_tracker_token - Id Token default=uuid_generate_v4() +-- | trackerIds which have been issued +Tracker sql=tt_tracker + Id UUID default=uuid_generate_v4() + name Text Unique expires UTCTime blocked Bool agent Text currentTicket TicketId Maybe deriving Eq Show Generic +TrackerStatus sql=tt_tracker_status + tracker TrackerId + timestamp UTCTime + status OwnTracks.Status + TrackerTicket ticket TicketId OnDeleteCascade OnUpdateCascade tracker TrackerId OnDeleteCascade OnUpdateCascade UniqueTrackerTicket ticket tracker -- raw frames as received from OBUs -TrainPing json sql=tt_trip_ping - ticket TicketId OnDeleteCascade OnUpdateCascade - token TrackerId OnDeleteSetNull OnUpdateCascade +Ping json sql=tt_trip_ping + ticket TicketId Maybe OnDeleteCascade OnUpdateCascade + trackerId TrackerId OnDeleteSetNull OnUpdateCascade geopos Geopos + -- accuracy Int Maybe + -- altitute Int Maybe + -- battery Int Maybe + -- TODO timestamp UTCTime - sequence Double + sequence Double Maybe deriving Show Generic Eq -- status of a train somewhen in time (may be in the future), @@ -156,6 +174,7 @@ TrainAnchor json sql=tt_trip_anchor deriving Show Generic Eq -- TODO: multi-language support? +-- announcements for the gtfs realtime Announcement json sql=tt_announcements Id UUID default=uuid_generate_v4() ticket TicketId OnDeleteCascade OnUpdateCascade @@ -177,8 +196,8 @@ instance ToSchema TicketId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) instance ToSchema TrackerId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) -instance ToSchema TrainPing where - declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") +instance ToSchema Ping where + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "ping") instance ToSchema TrainAnchor where declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor") instance ToSchema Announcement where 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) diff --git a/lib/Yesod/Orphans.hs b/lib/Yesod/Orphans.hs index f66f8af..dc5c77a 100644 --- a/lib/Yesod/Orphans.hs +++ b/lib/Yesod/Orphans.hs @@ -27,14 +27,17 @@ instance ToMarkup Day where instance ToMessage UTCTime where toMessage = formatW3 -instance ToMessage Token where - toMessage (Token uuid) = UUID.toText uuid +instance ToMessage TrackerId where + toMessage (TrackerKey uuid) = UUID.toText uuid instance ToMarkup UTCTime where toMarkup = toMarkup . formatW3 -instance ToMarkup Token where - toMarkup (Token uuid) = toMarkup (UUID.toText uuid) +instance ToMarkup TrackerId where + toMarkup (TrackerKey uuid) = toMarkup (UUID.toText uuid) + +instance ToMarkup UUID where + toMarkup uuid = toMarkup (UUID.toText uuid) instance ToMessage Double where toMessage = T.pack . show |