aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/API.hs55
-rw-r--r--lib/GTFS.hs10
-rw-r--r--lib/Persist.hs48
-rw-r--r--lib/Server.hs78
-rw-r--r--lib/Server/ControlRoom.hs85
-rw-r--r--lib/Server/GTFS_RT.hs20
-rw-r--r--lib/Server/Util.hs12
-rw-r--r--messages/de.msg7
-rw-r--r--messages/en.msg12
9 files changed, 204 insertions, 123 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 99e96ae..9016524 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,15 +1,17 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | The sole authorative definition of this server's API, given as a Servant-style
-- Haskell type. All other descriptions of the API are generated from this one.
-module API (API, CompleteAPI, GtfsRealtimeAPI, AdminAPI) where
+module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where
import Data.Map (Map)
import Data.Proxy (Proxy (..))
-import Data.Swagger (Swagger)
+import Data.Swagger (Swagger, ToSchema (..),
+ genericDeclareNamedSchema)
import Data.Swagger.ParamSchema (ToParamSchema (..))
import Data.Text (Text)
import Data.Time (Day, UTCTime)
@@ -25,12 +27,22 @@ import Servant.GTFS.Realtime (Proto)
import Servant.Swagger (HasSwagger (..))
import Web.Internal.FormUrlEncoded (Form)
+import Data.Aeson (FromJSON (..), genericParseJSON)
+import GHC.Generics (Generic)
import GTFS
import GTFS.Realtime.FeedEntity
import GTFS.Realtime.FeedMessage (FeedMessage)
import Persist
import Server.ControlRoom
+data RegisterJson = RegisterJson
+ { registerAgent :: Text }
+ deriving (Show, Generic)
+
+instance FromJSON RegisterJson where
+ parseJSON = genericParseJSON (aesonOptions "register")
+instance ToSchema RegisterJson where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
-- | The server's API (as it is actually intended).
type API = "stations" :> Get '[JSON] (Map StationID Station)
@@ -38,52 +50,31 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
-- ingress API (put this behind BasicAuth?)
-- TODO: perhaps require a first ping for registration?
- :<|> "train" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token
+ :<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
-- TODO: perhaps a websocket instead?
- :<|> "train" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] NoContent
+ :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] NoContent
:<|> "train" :> "ping" :> "ws" :> WebSocket
-- debug things
- :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
+ :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
+ :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
+ :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
:<|> "gtfs" :> GtfsRealtimeAPI
- -- TODO: this should be behind auth / OpenID or something
- :<|> "admin" :> AdminAPI
-- | The API used for publishing gtfs realtime updates
type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
:<|> "tripupdates" :> Get '[Proto] FeedMessage
:<|> "vehiclepositions" :> Get '[Proto] FeedMessage
--- | Admin API used for short-term timetable changes etc. ("leitstelle")
-type AdminAPI =
- "trip" :> "announce" :> ReqBody '[JSON] Announcement :> Post '[JSON] UUID
- :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] NoContent
- :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent
- :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent
--- TODO for this to be useful there ought to be a half-deep Trip type
--- (that has stops but not shapes)
- :<|> "extraordinary" :> "trip" :> ReqBody '[JSON] (Trip Deep Shallow) :> Post '[JSON] NoContent
-
-- | The server's API with an additional debug route for accessing the specification
-- itself. Split from API to prevent the API documenting the format in which it is
-- documented, which would be silly and way to verbose.
-type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
- :<|> API
- :<|> "cr" :> Raw
+type CompleteAPI =
+ "api" :> "openapi" :> Get '[JSON] Swagger
+ :<|> "api" :> API
+ :<|> Raw -- hook for yesod frontend
-- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
instance HasSwagger WebSocket where
toSwagger _ = toSwagger (Proxy @(Post '[JSON] NoContent))
-{-
-TODO:
-there should be a basic API allowing the questions:
- - what are the next trips leaving from $station? (or $geolocation?)
- - all stops of a given tripID
-
-then the "ingress" API:
- - train ping (location, estimated delay, etc.)
- - cancel trip
- - add trip?
-
--}
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 9259649..bfb1c49 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -51,6 +51,7 @@ import Web.Internal.FormUrlEncoded (FromForm (..))
import Web.Internal.HttpApiData (FromHttpApiData (..))
-- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
import Control.Lens
+import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Char (toLower)
import Data.Foldable (Foldable (fold))
import Data.Map (Map)
@@ -459,3 +460,12 @@ tripsAtStation GTFS{..} at = fmap stopTrip stops
tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep)
tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today)
+
+runsOnDay :: GTFS -> TripID -> Day -> Bool
+runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day
+ where same Trip{..} = tripTripID == trip
+
+runsToday :: MonadIO m => GTFS -> TripID -> m Bool
+runsToday gtfs trip = do
+ today <- liftIO getCurrentTime <&> utctDay
+ pure (runsOnDay gtfs trip today)
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 611da9e..39cdca1 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -58,32 +58,51 @@ instance ToSchema Token where
instance ToParamSchema Token where
toParamSchema _ = toParamSchema (Proxy @String)
-data AmendmentStatus = Cancelled | Added
+data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int
deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
derivePersistField "AmendmentStatus"
-instance FromHttpApiData AmendmentStatus where
- parseUrlPiece "Cancelled" = Right Cancelled
- parseUrlPiece "Added" = Right Added
- parseUrlPiece other = Left ("unknown AmendmentStatus: "<>other)
+-- instance FromHttpApiData AmendmentStatus where
+-- parseUrlPiece "Cancelled" = Right Cancelled
+-- parseUrlPiece "Added" = Right Added
+-- parseUrlPiece other = Left ("unknown AmendmentStatus: "<>other)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- | tokens which have been issued
-RunningTrip sql=tt_tracker_token
+Running sql=tt_tracker_token
Id Token default=uuid_generate_v4()
expires UTCTime
blocked Bool
- tripNumber Text
+ trip Text
+ day Day
vehicle Text Maybe
+ agent Text
deriving Eq Show Generic
-TripPing json sql=tt_trip_ping
- token RunningTripId
+-- raw frames as received from OBUs
+TrainPing json sql=tt_trip_ping
+ token RunningId
lat Double
long Double
- delay Double
timestamp UTCTime
deriving Show Generic Eq ToSchema
+-- status of a train somewhen in time (may be in the future),
+-- inferred from trainpings / entered via controlRoom
+TrainStatus sql=tt_train_status
+ timestamp UTCTime
+ trip TripID
+ day Day
+ when UTCTime
+ deriving Show Generic Eq ToSchema
+
+TripAnchor json sql=tt_trip_anchor
+ trip TripID
+ day Day
+ timestamp UTCTime
+ delay Int Maybe
+ msg Text Maybe
+ deriving Show Generic Eq ToSchema
+
-- TODO: multi-language support?
Announcement json sql=tt_announcements
Id UUID default=uuid_generate_v4()
@@ -102,16 +121,9 @@ ScheduleAmendment json sql=tt_schedule_amendement
status AmendmentStatus
-- only one special rule per TripID and Day (else incoherent)
TripAndDay trip day
-
--- TODO: possible to have regular trips moved in time without changing TripID?
-ExtraordinaryTrip sql=tt_extra_trip
- trip TripID
- day Text
- stops (Vector Text)
- stopTimes (Vector TimeOfDay)
|]
-instance ToSchema RunningTripId where
+instance ToSchema RunningId where
declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
diff --git a/lib/Server.hs b/lib/Server.hs
index f7ee81b..75617bd 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -11,8 +11,8 @@
-- Implementation of the API. This module is the main point of the program.
module Server (application) where
-import Control.Monad (forever, void, when)
-import Control.Monad.Extra (maybeM, whenM)
+import Control.Monad (forever, unless, void, when)
+import Control.Monad.Extra (maybeM, unlessM, whenM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (logWarnN)
import Control.Monad.Reader (forM)
@@ -35,8 +35,9 @@ import Database.Persist
import Database.Persist.Postgresql (SqlBackend, runMigration)
import Fmt ((+|), (|+))
import qualified Network.WebSockets as WS
-import Servant (Application, err401, err404,
- serve, throwError)
+import Servant (Application,
+ ServerError (errBody), err401,
+ err404, serve, throwError)
import Servant.API (NoContent (..), (:<|>) (..))
import Servant.Server (Handler, hoistServer)
import Servant.Swagger (toSwagger)
@@ -46,7 +47,8 @@ import GTFS
import Persist
import Server.ControlRoom
import Server.GTFS_RT (gtfsRealtimeServer)
-import Server.Util (Service, ServiceM, runService)
+import Server.Util (Service, ServiceM, runService,
+ sendErrorMsg)
import Yesod (toWaiAppPlain)
import System.IO.Unsafe
@@ -64,11 +66,12 @@ doMigration pool = runSql pool $
runMigration migrateAll
server :: GTFS -> Pool SqlBackend -> Service CompleteAPI
-server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip
- :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
- gtfsRealtimeServer gtfs dbpool
- :<|> adminServer gtfs dbpool)
- :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom "http://localhost:4000/cr" gtfs dbpool)))
+server gtfs@GTFS{..} dbpool = handleDebugAPI
+ :<|> (handleStations :<|> handleTimetable :<|> handleTrip
+ :<|> handleRegister :<|> handleTripPing :<|> handleWS
+ :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister
+ :<|> gtfsRealtimeServer gtfs dbpool)
+ :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool)))
where handleStations = pure stations
handleTimetable station maybeDay = do
-- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
@@ -80,13 +83,19 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
handleTrip trip = case M.lookup trip trips of
Just res -> pure res
Nothing -> throwError err404
- handleRegister tripID = do
- -- TODO registration may carry extra information!
+ handleRegister tripID RegisterJson{..} = do
+ today <- liftIO getCurrentTime <&> utctDay
+ when (not $ runsOnDay gtfs tripID today)
+ $ sendErrorMsg "this trip does not run today."
expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
- RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID Nothing)
+ RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent)
+ pure token
+ handleDebugRegister tripID day = do
+ expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
+ RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key")
pure token
handleTripPing ping = do
- lift $ checkTokenValid dbpool (coerce $ tripPingToken ping)
+ lift $ checkTokenValid dbpool (coerce $ trainPingToken ping)
-- TODO: are these always inserted in order?
runSql dbpool $ insert ping
pure NoContent
@@ -100,47 +109,34 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")")
liftIO $ WS.sendClose conn (C8.pack err)
Right ping -> do
- lift $ checkTokenValid dbpool (coerce $ tripPingToken ping)
+ lift $ checkTokenValid dbpool (coerce $ trainPingToken ping)
void $ runSql dbpool $ insert ping
handleDebugState = do
now <- liftIO getCurrentTime
runSql dbpool $ do
- running <- selectList [RunningTripBlocked ==. False, RunningTripExpires >=. now] []
- pairs <- forM running $ \(Entity token@(RunningTripKey uuid) _) -> do
- entities <- selectList [TripPingToken ==. token] []
+ running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] []
+ pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> do
+ entities <- selectList [TrainPingToken ==. token] []
pure (uuid, fmap entityVal entities)
pure (M.fromList pairs)
+ handleDebugTrain tripId day = do
+ unless (runsOnDay gtfs tripId day)
+ $ sendErrorMsg ("this trip does not run on "+|day|+".")
+ runSql dbpool $ do
+ tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] []
+ pings <- forM tokens $ \(Entity token _) -> do
+ selectList [TrainPingToken ==. token] [] <&> fmap entityVal
+ pure (concat pings)
handleDebugAPI = pure $ toSwagger (Proxy @API)
-adminServer :: GTFS -> Pool SqlBackend -> Service AdminAPI
-adminServer gtfs dbpool =
- addAnnounce :<|> delAnnounce :<|> modTripDate Added Cancelled
- :<|> modTripDate Cancelled Added :<|> extraTrip
- where addAnnounce ann@Announcement{..} = runSql dbpool $ do
- AnnouncementKey uuid <- insert ann
- pure uuid
- delAnnounce uuid = runSql dbpool $ do
- delete (AnnouncementKey uuid)
- pure NoContent
- modTripDate one two tripId day = runSql dbpool $ do
- getBy (TripAndDay tripId day) >>= \case
- Just (Entity key (ScheduleAmendment _ _ status)) -> do
- when (status == two) $ delete key
- pure NoContent
- Nothing -> do
- insert (ScheduleAmendment tripId day one)
- pure NoContent
- extraTrip = error "unimplemented!"
-
-
-- TODO: proper debug logging for expired tokens
checkTokenValid :: Pool SqlBackend -> Token -> Handler ()
checkTokenValid dbpool token = do
trip <- try $ runSql dbpool $ get (coerce token)
- when (runningTripBlocked trip)
+ when (runningBlocked trip)
$ throwError err401
- whenM (hasExpired (runningTripExpires trip))
+ whenM (hasExpired (runningExpires trip))
$ throwError err401
where try m = m >>= \case
Just a -> pure a
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 9ebea42..4ef3784 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -28,7 +28,7 @@ import qualified Data.Map as M
import Data.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Time (getCurrentTime, utctDay)
+import Data.Time (UTCTime, getCurrentTime, utctDay)
import Data.Time.Calendar (Day)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.UUID (UUID)
@@ -40,13 +40,9 @@ import Database.Persist.Sql (PersistFieldSql, SqlBackend,
runSqlPool)
import Fmt ((+|), (|+))
import GHC.Generics (Generic)
-import Persist (AmendmentStatus, Announcement (..),
- EntityField (..), Key (..),
- ScheduleAmendment (ScheduleAmendment),
- runSql)
import Server.Util (Service)
import Text.Blaze.Html (ToMarkup (..))
-import Text.Blaze.Internal (MarkupM(Empty))
+import Text.Blaze.Internal (MarkupM (Empty))
import Text.ProtocolBuffers (Default (defaultValue))
import Text.Read (readMaybe)
import Text.Shakespeare.Text
@@ -54,12 +50,12 @@ import Yesod
import Yesod.Form
import GTFS
+import Persist
data ControlRoom = ControlRoom
- { getBaseurl :: Text
- , getGtfs :: GTFS
- , getPool :: Pool SqlBackend
+ { getGtfs :: GTFS
+ , getPool :: Pool SqlBackend
}
mkMessage "ControlRoom" "messages" "en"
@@ -70,17 +66,16 @@ mkYesod "ControlRoom" [parseRoutes|
/train/id/#TripID/#Day TrainViewR GET
/train/announce/#TripID/#Day AnnounceR POST
/train/del-announce/#UUID DelAnnounceR GET
+/token/block/#Token TokenBlock GET
/trips TripsViewR GET
/trip/#TripID TripViewR GET
|]
emptyMarkup :: MarkupM a -> Bool
emptyMarkup (Empty _) = True
-emptyMarkup _ = False
+emptyMarkup _ = False
instance Yesod ControlRoom where
- approot = ApprootMaster (\cr -> getBaseurl cr)
-
defaultLayout w = do
PageContent{..} <- widgetToPageContent w
msgs <- getMessages
@@ -125,6 +120,9 @@ instance Yesod ControlRoom where
input {
grid-column: 2;
}
+ .blocked {
+ background-color: red;
+ }
<body>
$forall (status, msg) <- msgs
<p class="message #{status}">#{msg}
@@ -169,12 +167,28 @@ getTrainViewR trip day = do
Nothing -> notFound
Just res@Trip{..} -> do
anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
+ tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] []
+ lastPing <- runDB $ selectFirst [ TrainPingToken <-. (fmap entityKey tokens) ] [Desc TrainPingTimestamp]
defaultLayout $ do
mr <- getMessageRender
setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
[whamlet|
<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</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>)
+ $nothing
+ <em>(_{MsgNoTrainPing})
+ <p><strong>Estimated Delay</strong>: Todo!
+<section>
+ <h2>_{MsgStops}
+ <ol>
+ $forall Stop{..} <- tripStops
+ <li> #{stopArrival} #{stationName stopStation}
+<section>
<h2>_{MsgAnnouncements}
<ul>
$forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
@@ -186,13 +200,18 @@ getTrainViewR trip day = do
^{widget}
<button>Submit
<section>
- <h2>_{MsgStops}
- <ol>
- $forall Stop{..} <- tripStops
- <li> #{stopArrival} #{stationName stopStation}
-<section>
- <h2>Vehicle Position
- <div> Todo!
+ <h2>_{MsgTokens}
+ <table>
+ <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
+ $forall Entity (RunningKey key) Running{..} <- tokens
+ <tr :runningBlocked:.blocked>
+ <td title="#{runningAgent}">#{runningAgent}
+ <td title="#{key}">#{key}
+ <td title="#{runningExpires}">#{runningExpires}
+ $if runningBlocked
+ <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
+ $else
+ <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
|]
@@ -255,6 +274,19 @@ getDelAnnounceR uuid = do
Just Announcement{..} ->
redirect (TrainViewR announcementTrip announcementDay)
+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)
+ case maybe of
+ Just r@Running{..} -> do
+ liftIO $ print r
+ redirect (TrainViewR runningTrip runningDay)
+ Nothing -> notFound
+
announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
announceForm day tripId = renderDivs $ Announcement
@@ -274,3 +306,18 @@ instance ToMarkup Time where
instance ToMarkup Day where
toMarkup day = toMarkup (iso8601Show day)
+
+instance ToMessage UTCTime where
+ toMessage = formatW3
+
+instance ToMessage Token where
+ toMessage (Token uuid) = UUID.toText uuid
+
+instance ToMarkup UTCTime where
+ toMarkup = toMarkup . formatW3
+
+instance ToMarkup Token where
+ toMarkup (Token uuid) = toMarkup (UUID.toText uuid)
+
+instance ToMessage Double where
+ toMessage = T.pack . show
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index d771736..dfdd1eb 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -51,8 +51,8 @@ import GTFS.Realtime.VehiclePosition as VP (VehiclePositi
import Persist (Announcement (..),
EntityField (..),
Key (..),
- RunningTrip (..),
- TripPing (..),
+ Running (..),
+ TrainPing (..),
runSql)
import Servant.API ((:<|>) (..))
import Text.ProtocolBuffers (Utf8 (Utf8),
@@ -115,15 +115,15 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
-- TODO: how to propagate delay values to next stops?
pure undefined
handleVehiclePositions = runSql dbpool $ do
- (running :: [Entity RunningTrip]) <- selectList [] []
+ (running :: [Entity Running]) <- selectList [] []
pings <- forM running $ \(Entity key entity) -> do
- selectFirst [TripPingToken ==. key] [] <&> fmap (, entity)
+ selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
dFeedMessage $ Seq.fromList $ mkPosition <$> catMaybes pings
- where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) =
+ where mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) =
(dFeedEntity (toUtf8 . T.pack . show $ key))
{ FE.vehicle = Just $ VehiclePosition
- { trip = Just (dTripDescriptor runningTripTripNumber Nothing)
- , VP.vehicle = case runningTripVehicle of
+ { trip = Just (dTripDescriptor runningTrip Nothing)
+ , VP.vehicle = case runningVehicle of
Nothing -> Nothing
Just trainset -> Just $ VehicleDescriptor
{ VD.id = Nothing
@@ -132,8 +132,8 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
, VD.ext'field = defaultValue
}
, position = Just $ Position
- { latitude = double2Float tripPingLat
- , longitude = double2Float tripPingLong
+ { latitude = double2Float trainPingLat
+ , longitude = double2Float trainPingLong
, odometer = Nothing
, speed = Nothing
, bearing = Nothing
@@ -143,7 +143,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
, current_stop_sequence = Nothing
, stop_id = Nothing
, current_status = Nothing
- , timestamp = Just (toStupidTime tripPingTimestamp)
+ , timestamp = Just (toStupidTime trainPingTimestamp)
, congestion_level = Nothing
, occupancy_status = Nothing
, occupancy_percentage = Nothing
diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index a7a358e..5bfba52 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,15 +1,21 @@
{-# LANGUAGE FlexibleContexts #-}
-- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService) where
+module Server.Util (Service, ServiceM, runService, sendErrorMsg) where
import Control.Monad.Logger (LoggingT, runStderrLoggingT)
+import qualified Data.Aeson as A
import Data.ByteString (ByteString)
-import Servant (Handler, ServerError, ServerT, err302,
- errHeaders, throwError)
+import Data.Text (Text)
+import Servant (Handler, ServerError, ServerT, err404,
+ errBody, errHeaders, throwError)
type ServiceM = LoggingT Handler
type Service api = ServerT api ServiceM
runService :: ServiceM a -> Handler a
runService = runStderrLoggingT
+
+sendErrorMsg :: Text -> ServiceM a
+sendErrorMsg msg = throwError err404
+ { errBody = A.encode $ A.object ["error" A..= (404 :: Int), "msg" A..= msg] }
diff --git a/messages/de.msg b/messages/de.msg
index 66abf54..26f67ee 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -10,3 +10,10 @@ Trip: Fahrt
SwitchLanguage: Sprache wechseln
Switch: wechseln
Stops: Stationen
+Tokens: Token
+Expires: läuft ab
+Live: Echtzeitdaten
+LastPing: Letzte Meldung
+TrainPing lat long time: #{lat},#{long}, um #{time}
+NoTrainPing: keine empfangen
+raw: roh
diff --git a/messages/en.msg b/messages/en.msg
index d8b3be3..cc953ac 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -10,3 +10,15 @@ Trip: Trip
SwitchLanguage: Switch language to:
Switch: Switch
Stops: Stops
+Tokens: Tokens
+BlockToken: block
+UnblockToken: unblock
+Token: Token
+Status: Status
+Expires: Expires
+Agent: Agent
+Live: Live
+LastPing: Last Ping
+TrainPing lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time}
+NoTrainPing: none received
+raw: raw
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 17:25:41 +0000