aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
authorstuebinm2022-07-02 16:11:29 +0200
committerstuebinm2022-07-02 16:11:29 +0200
commitaeeaf83cf0dc72e9e39439984067563d08e57dec (patch)
tree416cb6b457c61cf09c46de1b35649287347a1e52 /lib/Server
parent6c25964c0165530e7db6650eea79cbac99031353 (diff)
more or less functional servicealerts for gtfs rt
(kinda barebones, but the important things should be there)
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/GTFSRT.hs155
1 files changed, 155 insertions, 0 deletions
diff --git a/lib/Server/GTFSRT.hs b/lib/Server/GTFSRT.hs
new file mode 100644
index 0000000..7035ccf
--- /dev/null
+++ b/lib/Server/GTFSRT.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Server.GTFSRT (gtfsRealtimeServer) where
+
+import qualified Data.Sequence as Seq
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Time.Clock.System (SystemTime (systemSeconds),
+ getSystemTime)
+import GTFS.Realtime.Alert as AL (Alert (..))
+import GTFS.Realtime.Alert.Cause (Cause (CONSTRUCTION))
+import GTFS.Realtime.Alert.Effect (Effect (DETOUR))
+import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel (WARNING))
+import GTFS.Realtime.EntitySelector as ES (EntitySelector (..))
+import GTFS.Realtime.FeedEntity as FE (FeedEntity (..))
+import GTFS.Realtime.FeedHeader (FeedHeader (FeedHeader))
+import GTFS.Realtime.FeedHeader.Incrementality (Incrementality (FULL_DATASET))
+import GTFS.Realtime.FeedMessage as FM (FeedMessage (..))
+import GTFS.Realtime.TimeRange (TimeRange (TimeRange))
+import GTFS.Realtime.TranslatedString (TranslatedString (TranslatedString))
+import GTFS.Realtime.TranslatedString.Translation (Translation (Translation))
+import GTFS.Realtime.TripDescriptor as TD (TripDescriptor (..))
+import Prelude hiding (id)
+import Text.ProtocolBuffers (Utf8 (Utf8),
+ defaultValue)
+import Text.ProtocolBuffers.WireMessage (zzEncode64)
+
+import API (GtfsRealtimeAPI)
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.ByteString.Lazy (fromStrict)
+import Data.Functor ((<&>))
+import Data.Pool (Pool)
+import Data.Sequence (Seq)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time (Day)
+import Data.Time.Calendar (Day, toGregorian)
+import qualified Data.UUID as UUID
+import Database.Persist (Entity (Entity),
+ selectList)
+import Database.Persist.Postgresql (SqlBackend)
+import GTFS (GTFS)
+import Persist (Announcement (..),
+ Key (..),
+ RunningTrip,
+ runSql)
+import Servant.API ((:<|>) (..))
+import Servant.Server (Handler (Handler),
+ Server)
+
+
+uuidUtf8 :: UUID.UUID -> Utf8
+uuidUtf8 = Utf8 . fromStrict . UUID.toASCIIBytes
+
+toUtf8 :: Text -> Utf8
+toUtf8 = Utf8 . fromStrict . encodeUtf8
+
+-- | formats a day in the "stupid" format used by gtfs realtime
+toStupidDate :: Day -> Utf8
+toStupidDate date = toUtf8
+ $ pad 4 year <> pad 2 month <> pad 2 day
+ where (year, month, day) = toGregorian date
+ pad len num = T.pack $ if ndigits < len
+ then replicate (len - ndigits) '0' <> show num
+ else show num
+ where ndigits = length (show num)
+
+
+gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Server GtfsRealtimeAPI
+gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
+ where handleServiceAlerts = runSql dbpool $ do
+ -- TODO filter: only select current & future days
+ announcements <- selectList [] []
+ dFeedMessage $ Seq.fromList $ fmap mkAlert announcements
+ where mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+ (dFeedEntity (uuidUtf8 uuid))
+ { alert =
+ (Just $ Alert
+ { active_period = [TimeRange Nothing Nothing defaultValue]
+ -- TODO: is this time range reasonable, needed, etc.?
+ , informed_entity =
+ [dEntitySelector
+ { trip =
+ Just (TripDescriptor
+ { trip_id = Just (toUtf8 announcementTrip)
+ , route_id = Nothing
+ , direction_id = Nothing
+ , start_time = Nothing
+ , start_date = Just (toStupidDate announcementDay)
+ , schedule_relationship = Nothing
+ , TD.ext'field = defaultValue
+ })
+ }
+ ]
+ , cause = Nothing
+ , effect = Nothing
+ , url = fmap (lang "de" . toUtf8) announcementUrl
+ , header_text = Just $ lang "de" (toUtf8 announcementHeader)
+ , description_text = Just $ lang "de" (toUtf8 announcementMessage)
+ , tts_header_text = Nothing
+ , tts_description_text = Nothing
+ , severity_level = Nothing
+ , image = Nothing
+ , image_alternative_text = Nothing
+ , AL.ext'field = defaultValue
+ }) }
+ handleTripUpdates = runSql dbpool $ do
+ -- TODO: how to propagate delay values to next stops?
+ pure undefined
+ handleVehiclePositions = runSql dbpool $ do
+ -- TODO: how to know which trips are currently running?
+ pure undefined
+
+
+lang :: Utf8 -> Utf8 -> TranslatedString
+lang code msg = TranslatedString [Translation msg (Just code) defaultValue] defaultValue
+
+-- | a default FeedMessage, issued at the current system time
+-- TODO: do we ever need incremental updates?
+-- TODO: maybe instead use last update time?
+dFeedMessage :: MonadIO m => Seq FeedEntity -> m FeedMessage
+dFeedMessage entities = do
+ now <- liftIO getSystemTime <&> systemSeconds
+ pure $ FeedMessage
+ { header = FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue
+ , entity = entities
+ , FM.ext'field = defaultValue
+ }
+
+-- | a dummy FeedEntity (use record updates to add meaningful values to this)
+dFeedEntity :: Utf8 -> FeedEntity
+dFeedEntity id = FeedEntity
+ { id
+ , is_deleted = Nothing
+ , trip_update = Nothing
+ , vehicle = Nothing
+ , alert = Nothing
+ , shape = Nothing
+ , FE.ext'field = defaultValue
+ }
+
+dEntitySelector :: EntitySelector
+dEntitySelector = EntitySelector
+ { agency_id = Nothing
+ , route_id = Nothing
+ , route_type = Nothing
+ , trip = Nothing
+ , stop_id = Nothing
+ , direction_id = Nothing
+ , ES.ext'field = defaultValue
+ }