diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 13 | ||||
| -rw-r--r-- | lib/Server.hs | 64 |
2 files changed, 75 insertions, 2 deletions
@@ -5,7 +5,7 @@ -- | 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) where +module API (API, CompleteAPI, GtfsRealtimeAPI) where import Data.Map (Map) import Data.Proxy (Proxy (..)) @@ -21,6 +21,10 @@ import Servant (Application, import Servant.API (Capture, FromHttpApiData, Get, JSON, Post, QueryParam, ReqBody, type (:<|>) ((:<|>))) +import Servant.GTFS.Realtime (Proto) +import GTFS.Realtime.FeedEntity +import GTFS.Realtime.FeedMessage (FeedMessage) + -- | The server's API (as it is actually intended). type API = "stations" :> Get '[JSON] (Map StationID Station) @@ -33,6 +37,13 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) :<|> "train" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] () -- debug things :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing]) + :<|> "gtfs" :> GtfsRealtimeAPI + +-- | The API used for publishing gtfs realtime updates +type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage + :<|> "tripupdates" :> Get '[Proto] FeedEntity + :<|> "vehiclepositions" :> Get '[Proto] FeedEntity + -- | 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 diff --git a/lib/Server.hs b/lib/Server.hs index 2375d2b..1aaf630 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedLists #-} -- Implementation of the API. This module is the main point of the program. @@ -57,9 +58,27 @@ import Servant.Docs (DocCapture (..), import Servant.Server (Handler) import Servant.Swagger (toSwagger) import Web.PathPieces (PathPiece) +import Text.ProtocolBuffers (defaultValue) +import qualified Data.Sequence as Seq +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Time.Clock.System (SystemTime(systemSeconds), getSystemTime) +import Text.ProtocolBuffers.WireMessage (zzEncode64) + +import GTFS.Realtime.FeedMessage (FeedMessage(..)) +import GTFS.Realtime.FeedEntity ( FeedEntity(FeedEntity) ) +import GTFS.Realtime.FeedHeader (FeedHeader(FeedHeader)) +import GTFS.Realtime.FeedHeader.Incrementality (Incrementality(FULL_DATASET)) import API import Persist +import GTFS.Realtime.Alert (Alert(Alert)) +import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel(WARNING)) +import GTFS.Realtime.Alert.Cause (Cause(CONSTRUCTION)) +import GTFS.Realtime.Alert.Effect (Effect(DETOUR)) +import GTFS.Realtime.TranslatedString (TranslatedString(TranslatedString)) +import GTFS.Realtime.TranslatedString.Translation (Translation(Translation)) +import GTFS.Realtime.TimeRange (TimeRange(TimeRange)) +import GTFS.Realtime.EntitySelector (EntitySelector(EntitySelector)) application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do @@ -75,7 +94,7 @@ doMigration pool = runSql pool $ server :: GTFS -> Pool SqlBackend -> Server CompleteAPI server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip - :<|> handleRegister :<|> handleTripPing :<|> handleDebugState + :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer where handleStations = pure stations handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) @@ -106,6 +125,49 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime pure (M.fromList pairs) handleDebugAPI = pure $ toSwagger (Proxy @API) +gtfsRealtimeServer :: Server GtfsRealtimeAPI +gtfsRealtimeServer = handleServiceAlerts :<|> handleDummy :<|> handleDummy + where handleDummy = do + pure $ FeedEntity + "1234" + Nothing + Nothing + Nothing + Nothing + Nothing + defaultValue + handleServiceAlerts = do + now <- liftIO getSystemTime <&> systemSeconds + pure $ FeedMessage + (FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue) + (Seq.fromList + [FeedEntity + "0" + Nothing + Nothing + Nothing + (Just $ Alert + [TimeRange (Just $ fromIntegral (now - 1000)) Nothing defaultValue] + [EntitySelector Nothing (Just "Passau - Freyung") Nothing Nothing Nothing Nothing defaultValue] + (Just CONSTRUCTION) + (Just DETOUR) + (lang "de" "https://ilztalbahn.eu") + (lang "de" "Da liegt ein Baum auf der Strecke") + (lang "de" "Leider liegt ein Baum auf der Strecke. Solange fährt hier nix.") + Nothing + Nothing + (Just WARNING) + Nothing + Nothing + defaultValue + ) + Nothing + defaultValue + ]) + defaultValue + lang code msg = Just $ TranslatedString [Translation msg (Just code) defaultValue] defaultValue + + -- TODO: proper debug logging for expired tokens checkTokenValid :: Pool SqlBackend -> Token -> Handler () checkTokenValid dbpool token = do |