aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs13
-rw-r--r--lib/Server.hs64
2 files changed, 75 insertions, 2 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 51c3690..34b127a 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -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