gtfs realtime proof of concept

this adds a package for protobuf stuff, generated via hprotoc. Seems to
work kinda fine?

(the generated API is horrible though, will have to write some wrappers
for that)

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