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)

1 files changed, 63 insertions, 1 deletions

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