From 4e636c67c2794317de4f5ed71bbc23b12c3131d0 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 2 Jul 2022 18:20:43 +0200 Subject: better module names --- lib/Server.hs | 2 +- lib/Server/GTFSRT.hs | 208 ------------------------------------------------- lib/Server/GTFS_RT.hs | 209 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 210 insertions(+), 209 deletions(-) delete mode 100644 lib/Server/GTFSRT.hs create mode 100644 lib/Server/GTFS_RT.hs (limited to 'lib') diff --git a/lib/Server.hs b/lib/Server.hs index 2b86b6e..7802911 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -61,7 +61,7 @@ import Web.PathPieces (PathPiece) import API import Persist -import Server.GTFSRT (gtfsRealtimeServer) +import Server.GTFS_RT (gtfsRealtimeServer) application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do diff --git a/lib/Server/GTFSRT.hs b/lib/Server/GTFSRT.hs deleted file mode 100644 index bd285ff..0000000 --- a/lib/Server/GTFSRT.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# 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, - utcToSystemTime) -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 (forM) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString.Lazy (fromStrict) -import Data.Functor ((<&>)) -import Data.Maybe (catMaybes) -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 Data.Time.Clock (UTCTime) -import qualified Data.UUID as UUID -import Data.Word (Word64) -import Database.Persist (Entity (Entity), - PersistQueryRead (selectFirst), - selectList, (==.)) -import Database.Persist.Postgresql (SqlBackend) -import GHC.Float (double2Float) -import GTFS (GTFS, TripID) -import GTFS.Realtime.Position as POS (Position (..)) -import GTFS.Realtime.VehicleDescriptor as VD (VehicleDescriptor (..)) -import GTFS.Realtime.VehiclePosition as VP (VehiclePosition (..)) -import Persist (Announcement (..), - EntityField (TripPingToken), - Key (..), - RunningTrip (..), - TripPing (..), - 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) - --- | basically unix timestamps, raw (because why not i guess) -toStupidTime :: UTCTime -> Word64 -toStupidTime = fromIntegral . systemSeconds . utcToSystemTime - -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 - { ES.trip = - Just (dTripDescriptor announcementTrip (Just announcementDay)) - } - ] - , 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 - (running :: [Entity RunningTrip]) <- selectList [] [] - pings <- forM running $ \(Entity key entity) -> do - selectFirst [TripPingToken ==. key] [] <&> fmap (, entity) - dFeedMessage $ Seq.fromList $ fmap mkPosition $ catMaybes pings - where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) = - (dFeedEntity (toUtf8 . T.pack . show $ key)) - { FE.vehicle = Just $ VehiclePosition - { trip = Just (dTripDescriptor runningTripTripNumber Nothing) - , VP.vehicle = case runningTripTrainset of - Nothing -> Nothing - Just trainset -> Just $ VehicleDescriptor - { VD.id = Nothing - , VD.label = (Just (toUtf8 trainset)) - , VD.license_plate = Nothing - , VD.ext'field = defaultValue - } - , position = Just $ Position - { latitude = double2Float tripPingLat - , longitude = double2Float tripPingLong - , odometer = Nothing - , speed = Nothing - , bearing = Nothing - , POS.ext'field = defaultValue - } - -- TODO: at least one of these should probably be given - , current_stop_sequence = Nothing - , stop_id = Nothing - , current_status = Nothing - , timestamp = Just (toStupidTime tripPingTimestamp) - , congestion_level = Nothing - , occupancy_status = Nothing - , occupancy_percentage = Nothing - , multi_carriage_details = [] - , VP.ext'field = defaultValue - } - } - - -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 - } - -dTripDescriptor :: TripID -> Maybe Day -> TripDescriptor -dTripDescriptor tripID day = TripDescriptor - { trip_id = Just (toUtf8 tripID) - , route_id = Nothing - , direction_id = Nothing - , start_time = Nothing - , start_date = fmap toStupidDate day - , schedule_relationship = Nothing - , TD.ext'field = defaultValue - } diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs new file mode 100644 index 0000000..e2b23e0 --- /dev/null +++ b/lib/Server/GTFS_RT.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Server.GTFS_RT (gtfsRealtimeServer) where + +import qualified Data.Sequence as Seq +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Time.Clock.System (SystemTime (systemSeconds), + getSystemTime, + utcToSystemTime) +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 (forM) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString.Lazy (fromStrict) +import Data.Functor ((<&>)) +import Data.Maybe (catMaybes) +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 Data.Time.Clock (UTCTime) +import qualified Data.UUID as UUID +import Data.Word (Word64) +import Database.Persist (Entity (Entity), + PersistQueryRead (selectFirst), + selectList, (==.)) +import Database.Persist.Postgresql (SqlBackend) +import GHC.Float (double2Float) +import GTFS (GTFS, TripID) +import GTFS.Realtime.Position as POS (Position (..)) +import GTFS.Realtime.VehicleDescriptor as VD (VehicleDescriptor (..)) +import GTFS.Realtime.VehiclePosition as VP (VehiclePosition (..)) +import Persist (Announcement (..), + EntityField (TripPingToken), + Key (..), + RunningTrip (..), + TripPing (..), + 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) + +-- | basically unix timestamps, raw (because why not i guess) +toStupidTime :: UTCTime -> Word64 +toStupidTime = fromIntegral . systemSeconds . utcToSystemTime + +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 + { ES.trip = + Just (dTripDescriptor announcementTrip (Just announcementDay)) + } + ] + , 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 + error "unimplemented!" + -- TODO: how to propagate delay values to next stops? + pure undefined + handleVehiclePositions = runSql dbpool $ do + (running :: [Entity RunningTrip]) <- selectList [] [] + pings <- forM running $ \(Entity key entity) -> do + selectFirst [TripPingToken ==. key] [] <&> fmap (, entity) + dFeedMessage $ Seq.fromList $ fmap mkPosition $ catMaybes pings + where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) = + (dFeedEntity (toUtf8 . T.pack . show $ key)) + { FE.vehicle = Just $ VehiclePosition + { trip = Just (dTripDescriptor runningTripTripNumber Nothing) + , VP.vehicle = case runningTripTrainset of + Nothing -> Nothing + Just trainset -> Just $ VehicleDescriptor + { VD.id = Nothing + , VD.label = (Just (toUtf8 trainset)) + , VD.license_plate = Nothing + , VD.ext'field = defaultValue + } + , position = Just $ Position + { latitude = double2Float tripPingLat + , longitude = double2Float tripPingLong + , odometer = Nothing + , speed = Nothing + , bearing = Nothing + , POS.ext'field = defaultValue + } + -- TODO: at least one of these should probably be given + , current_stop_sequence = Nothing + , stop_id = Nothing + , current_status = Nothing + , timestamp = Just (toStupidTime tripPingTimestamp) + , congestion_level = Nothing + , occupancy_status = Nothing + , occupancy_percentage = Nothing + , multi_carriage_details = [] + , VP.ext'field = defaultValue + } + } + + +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 + } + +dTripDescriptor :: TripID -> Maybe Day -> TripDescriptor +dTripDescriptor tripID day = TripDescriptor + { trip_id = Just (toUtf8 tripID) + , route_id = Nothing + , direction_id = Nothing + , start_time = Nothing + , start_date = fmap toStupidDate day + , schedule_relationship = Nothing + , TD.ext'field = defaultValue + } -- cgit v1.2.3