diff options
Diffstat (limited to 'lib/Server')
| -rw-r--r-- | lib/Server/GTFSRT.hs | 155 |
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 + } |