more or less functional servicealerts for gtfs rt

(kinda barebones, but the important things should be there)

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
+  }