From aeeaf83cf0dc72e9e39439984067563d08e57dec Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 2 Jul 2022 16:11:29 +0200
Subject: more or less functional servicealerts for gtfs rt

(kinda barebones, but the important things should be there)
---
 lib/Server.hs | 70 +++++++----------------------------------------------------
 1 file changed, 8 insertions(+), 62 deletions(-)

(limited to 'lib/Server.hs')

diff --git a/lib/Server.hs b/lib/Server.hs
index 1aaf630..6c293f0 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -3,9 +3,9 @@
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedLists    #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeApplications   #-}
-{-# LANGUAGE OverloadedLists #-}
 
 
 -- Implementation of the API. This module is the main point of the program.
@@ -13,7 +13,7 @@ module Server (application) where
 import           Conduit                        (MonadTrans (lift), ResourceT)
 import           Control.Concurrent.STM
 import           Control.Monad                  (when)
-import           Control.Monad.Extra            (whenM, maybeM)
+import           Control.Monad.Extra            (maybeM, whenM)
 import           Control.Monad.IO.Class         (MonadIO (liftIO))
 import           Control.Monad.Logger.CallStack (NoLoggingT)
 import           Control.Monad.Reader           (forM)
@@ -58,27 +58,10 @@ 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))
+import           Server.GTFSRT                  (gtfsRealtimeServer)
 
 application :: GTFS -> Pool SqlBackend -> IO Application
 application gtfs dbpool = do
@@ -94,7 +77,8 @@ doMigration pool = runSql pool $
 
 server :: GTFS -> Pool SqlBackend -> Server CompleteAPI
 server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
-  :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer
+  :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool
+  :<|> adminServer gtfs dbpool
   where handleStations = pure stations
         handleTimetable station maybeDay = do
           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
@@ -125,47 +109,9 @@ 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
+
+adminServer :: GTFS -> Pool SqlBackend -> Server AdminAPI
+adminServer = undefined
 
 
 -- TODO: proper debug logging for expired tokens
-- 
cgit v1.2.3