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) --- cabal.project.freeze | 277 --------------------------------------------------- lib/API.hs | 56 +++++++---- lib/GTFS.hs | 31 +++--- lib/Persist.hs | 9 +- lib/Server.hs | 70 ++----------- lib/Server/GTFSRT.hs | 155 ++++++++++++++++++++++++++++ todo.org | 8 +- tracktrain.cabal | 5 +- 8 files changed, 232 insertions(+), 379 deletions(-) delete mode 100644 cabal.project.freeze create mode 100644 lib/Server/GTFSRT.hs diff --git a/cabal.project.freeze b/cabal.project.freeze deleted file mode 100644 index 4c66197..0000000 --- a/cabal.project.freeze +++ /dev/null @@ -1,277 +0,0 @@ -active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.2.1.0, - any.HUnit ==1.6.2.0, - any.OneTuple ==0.3.1, - any.Only ==0.1, - any.QuickCheck ==2.14.2, - QuickCheck -old-random +templatehaskell, - any.StateVar ==1.2.2, - any.adjunctions ==4.4.1, - any.aeson ==2.0.3.0, - aeson -cffi +ordered-keymap, - any.aeson-pretty ==0.8.9, - aeson-pretty -lib-only, - any.ansi-terminal ==0.11.3, - ansi-terminal -example, - any.ansi-wl-pprint ==0.6.9, - ansi-wl-pprint -example, - any.appar ==0.1.8, - any.array ==0.5.4.0, - any.asn1-encoding ==0.9.6, - any.asn1-parse ==0.9.5, - any.asn1-types ==0.3.4, - any.assoc ==1.0.2, - any.async ==2.2.4, - async -bench, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.attoparsec-iso8601 ==1.0.2.1, - attoparsec-iso8601 -developer -fast, - any.auto-update ==0.1.6, - any.base ==4.14.3.0, - any.base-compat ==0.12.1, - any.base-compat-batteries ==0.12.1, - any.base-orphans ==0.8.6, - any.base64-bytestring ==1.2.1.0, - any.basement ==0.0.14, - any.bifunctors ==5.5.12, - bifunctors +semigroups +tagged, - any.binary ==0.8.8.0, - any.blaze-builder ==0.4.2.2, - any.blaze-html ==0.9.1.2, - any.blaze-markup ==0.8.2.8, - any.boring ==0.2, - boring +tagged, - any.bsb-http-chunked ==0.0.0.4, - any.byteorder ==1.0.4, - any.bytestring ==0.10.12.0, - any.bytestring-builder ==0.10.8.2.0, - bytestring-builder +bytestring_has_builder, - any.cabal-doctest ==1.0.9, - any.call-stack ==0.4.0, - any.case-insensitive ==1.2.1.0, - any.cassava ==0.5.2.0, - cassava -bytestring--lt-0_10_4, - any.clock ==0.8.3, - clock -llvm, - any.cmdargs ==0.10.21, - cmdargs +quotation -testprog, - any.colour ==2.3.6, - any.comonad ==5.0.8, - comonad +containers +distributive +indexed-traversable, - any.conduit ==1.3.4.2, - any.conduit-extra ==1.3.6, - any.constraints ==0.13.4, - any.containers ==0.6.5.1, - any.contravariant ==1.5.5, - contravariant +semigroups +statevar +tagged, - any.cookie ==0.4.5, - any.cryptohash-md5 ==0.11.101.0, - any.cryptohash-sha1 ==0.11.101.0, - any.cryptonite ==0.30, - cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.data-default-class ==0.1.2.0, - any.data-fix ==0.3.2, - any.dec ==0.0.4, - any.deepseq ==1.4.4.0, - any.digest ==0.0.1.3, - digest -bytestring-in-base, - any.directory ==1.3.6.0, - any.distributive ==0.6.2.1, - distributive +semigroups +tagged, - any.dlist ==1.0, - dlist -werror, - any.double-conversion ==2.0.4.1, - double-conversion -developer, - any.easy-file ==0.2.2, - any.either ==5.0.2, - any.entropy ==0.4.1.7, - entropy -halvm, - any.exceptions ==0.10.4, - any.fast-logger ==3.1.1, - any.file-embed ==0.0.15.0, - any.filepath ==1.4.2.1, - any.fmt ==0.6.3.0, - any.formatting ==7.1.3, - any.free ==5.1.8, - any.generics-sop ==0.5.1.2, - any.ghc ==8.10.7, - any.ghc-boot ==8.10.7, - any.ghc-boot-th ==8.10.7, - any.ghc-heap ==8.10.7, - any.ghc-prim ==0.6.1, - any.ghci ==8.10.7, - any.hashable ==1.4.0.2, - hashable +containers +integer-gmp -random-initial-seed, - any.hourglass ==0.2.12, - any.hpc ==0.6.1.0, - any.hsc2hs ==0.68.8, - hsc2hs -in-ghc-tree, - any.hspec ==2.10.0, - any.hspec-core ==2.10.0, - any.hspec-discover ==2.10.0, - any.hspec-expectations ==0.8.2, - any.http-api-data ==0.4.3, - http-api-data -use-text-show, - any.http-date ==0.0.11, - any.http-media ==0.8.0.0, - any.http-types ==0.12.3, - any.http2 ==3.0.3, - http2 -devel -doc -h2spec, - any.indexed-profunctors ==0.1.1, - any.indexed-traversable ==0.1.2, - any.indexed-traversable-instances ==0.1.1, - any.insert-ordered-containers ==0.2.5.1, - any.integer-gmp ==1.0.3.0, - any.integer-logarithms ==1.0.3.1, - integer-logarithms -check-bounds +integer-gmp, - any.invariant ==0.5.6, - any.iproute ==1.7.12, - any.kan-extensions ==5.2.4, - any.lens ==5.1.1, - lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.lift-type ==0.1.0.1, - any.lifted-base ==0.2.3.12, - any.memory ==0.17.0, - memory +support_bytestring +support_deepseq, - any.microlens ==0.4.13.0, - any.mime-types ==0.1.0.9, - any.mmorph ==1.2.0, - any.monad-control ==1.0.3.1, - any.monad-logger ==0.3.36, - monad-logger +template_haskell, - any.monad-loops ==0.4.3, - monad-loops +base4, - any.mono-traversable ==1.0.15.3, - any.mtl ==2.2.2, - any.network ==3.1.2.7, - network -devel, - any.network-byte-order ==0.1.6, - any.network-info ==0.2.1, - any.network-uri ==2.6.4.1, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.3, - any.optics-core ==0.4.1, - optics-core -explicit-generic-labels, - any.optics-extra ==0.4.2.1, - any.optics-th ==0.4.1, - any.optparse-applicative ==0.17.0.0, - optparse-applicative +process, - any.parallel ==3.2.2.0, - any.parsec ==3.1.14.0, - any.path-pieces ==0.2.1, - any.pem ==0.2.4, - any.persistent ==2.14.0.1, - any.persistent-postgresql ==2.13.5.0, - any.postgresql-libpq ==0.9.4.3, - postgresql-libpq -use-pkg-config, - any.postgresql-simple ==0.6.4, - any.pretty ==1.1.3.6, - any.primitive ==0.7.4.0, - any.process ==1.6.13.2, - any.profunctors ==5.6.2, - any.psqueues ==0.2.7.3, - any.quickcheck-io ==0.2.0, - any.random ==1.2.1.1, - any.reflection ==2.1.6, - reflection -slow +template-haskell, - any.regex-base ==0.94.0.2, - any.regex-tdfa ==1.3.1.2, - regex-tdfa -force-o2, - any.resource-pool ==0.3.0.0, - any.resourcet ==1.2.5, - any.rts ==1.0.1, - any.scientific ==0.3.7.0, - scientific -bytestring-builder -integer-simple, - any.semialign ==1.2.0.1, - semialign +semigroupoids, - any.semigroupoids ==5.3.7, - semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, - any.semigroups ==0.20, - semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, - any.servant ==0.19, - any.servant-docs ==0.12, - any.servant-server ==0.19.1, - any.servant-swagger ==1.1.11, - any.setenv ==0.1.1.3, - any.silently ==1.2.5.2, - any.simple-sendfile ==0.2.30, - simple-sendfile +allow-bsd, - any.singleton-bool ==0.1.6, - any.some ==1.0.3, - some +newtype-unsafe, - any.sop-core ==0.5.0.2, - any.split ==0.2.3.4, - any.splitmix ==0.1.0.4, - splitmix -optimised-mixer, - any.stm ==2.5.0.1, - any.stm-chans ==3.0.0.6, - any.streaming-commons ==0.2.2.4, - streaming-commons -use-bytestring-builder, - any.strict ==0.4.0.1, - strict +assoc, - any.string-conversions ==0.4.0.1, - any.swagger2 ==2.8.2, - any.tagged ==0.8.6.1, - tagged +deepseq +transformers, - any.template-haskell ==2.16.0.0, - any.terminfo ==0.4.1.4, - any.text ==1.2.4.1, - any.text-short ==0.1.5, - text-short -asserts, - any.tf-random ==0.5, - any.th-abstraction ==0.4.3.0, - any.th-compat ==0.1.3, - any.th-lift ==0.8.2, - any.th-lift-instances ==0.1.19, - any.these ==1.1.1.1, - these +assoc, - any.time ==1.9.3, - any.time-compat ==1.9.6.1, - time-compat -old-locale, - any.time-locale-compat ==0.1.1.5, - time-locale-compat -old-locale, - any.time-manager ==0.0.0, - any.transformers ==0.5.6.2, - any.transformers-base ==0.4.6, - transformers-base +orphaninstances, - any.transformers-compat ==0.7.1, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.type-equality ==1, - any.typed-process ==0.2.10.1, - any.universe-base ==1.1.3, - any.unix ==2.7.2.2, - any.unix-compat ==0.6, - unix-compat -old-time, - any.unix-time ==0.4.7, - any.unliftio ==0.2.22.0, - any.unliftio-core ==0.2.0.1, - any.unordered-containers ==0.2.19.1, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.uuid ==1.3.15, - any.uuid-types ==1.0.5, - any.vault ==0.3.1.5, - vault +useghc, - any.vector ==0.12.3.1, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.8.0.4, - vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, - any.void ==0.7.3, - void -safe, - any.wai ==3.2.3, - any.wai-app-static ==3.1.7.4, - wai-app-static +cryptonite -print, - any.wai-extra ==3.1.12.1, - wai-extra -build-example, - any.wai-logger ==2.4.0, - any.warp ==3.3.21, - warp +allow-sendfilefd -network-bytestring -warp-debug +x509, - any.witherable ==0.4.2, - any.word8 ==0.1.3, - any.x509 ==1.7.7, - any.zip-archive ==0.4.2.1, - zip-archive -executable, - any.zlib ==0.6.3.0, - zlib -bundled-c-zlib -non-blocking-ffi -pkg-config -index-state: hackage.haskell.org 2022-06-04T09:58:07Z diff --git a/lib/API.hs b/lib/API.hs index 34b127a..5afd041 100644 --- a/lib/API.hs +++ b/lib/API.hs @@ -5,31 +5,33 @@ -- | The sole authorative definition of this server's API, given as a Servant-style -- Haskell type. All other descriptions of the API are generated from this one. -module API (API, CompleteAPI, GtfsRealtimeAPI) where +module API (API, CompleteAPI, GtfsRealtimeAPI, AdminAPI) where -import Data.Map (Map) -import Data.Proxy (Proxy (..)) -import Data.Swagger (Swagger) -import Data.Swagger.ParamSchema (ToParamSchema (..)) -import Data.Time (Day, UTCTime) +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Swagger (Swagger) +import Data.Swagger.ParamSchema (ToParamSchema (..)) +import Data.Text (Text) +import Data.Time (Day, UTCTime) import GTFS +import GTFS.Realtime.FeedEntity +import GTFS.Realtime.FeedMessage (FeedMessage) import Persist -import Servant (Application, - FromHttpApiData (parseUrlPiece), - Server, err401, err404, serve, - throwError, type (:>)) -import Servant.API (Capture, FromHttpApiData, Get, JSON, - Post, QueryParam, ReqBody, - type (:<|>) ((:<|>))) -import Servant.GTFS.Realtime (Proto) -import GTFS.Realtime.FeedEntity -import GTFS.Realtime.FeedMessage (FeedMessage) +import Servant (Application, + FromHttpApiData (parseUrlPiece), + Server, err401, err404, serve, + throwError, type (:>)) +import Servant.API (Capture, FromHttpApiData, Get, JSON, + Post, QueryParam, ReqBody, + type (:<|>) ((:<|>))) +import Servant.GTFS.Realtime (Proto) +import Data.UUID (UUID) -- | The server's API (as it is actually intended). type API = "stations" :> Get '[JSON] (Map StationID Station) - :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep)) - :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep) + :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep)) + :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep) -- ingress API (put this behind BasicAuth?) -- TODO: perhaps require a first ping for registration? :<|> "train" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token @@ -38,11 +40,22 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) -- debug things :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing]) :<|> "gtfs" :> GtfsRealtimeAPI + :<|> "admin" :> AdminAPI -- | The API used for publishing gtfs realtime updates type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage - :<|> "tripupdates" :> Get '[Proto] FeedEntity - :<|> "vehiclepositions" :> Get '[Proto] FeedEntity + :<|> "tripupdates" :> Get '[Proto] FeedMessage + :<|> "vehiclepositions" :> Get '[Proto] FeedMessage + +-- | Admin API used for short-term timetable changes etc. ("leitstelle") +type AdminAPI = + "trip" :> "announce" :> Capture "Trip ID" TripID :> QueryParam "day" Day :> ReqBody '[JSON] Text :> Post '[JSON] UUID + :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] () + :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Post '[JSON] () + :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Post '[JSON] () +-- TODO for this to be useful there ought to be a half-deep Trip type +-- (that has stops but not shapes) + :<|> "extraordinary" :> "trip" :> ReqBody '[JSON] (Trip Deep Shallow) :> Post '[JSON] () -- | The server's API with an additional debug route for accessing the specification @@ -52,9 +65,12 @@ type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger :<|> API + instance ToParamSchema (Maybe UTCTime) where toParamSchema _ = toParamSchema (Proxy @UTCTime) + + {- TODO: there should be a basic API allowing the questions: diff --git a/lib/GTFS.hs b/lib/GTFS.hs index bd29b6d..68d92dc 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -189,7 +189,7 @@ instance FromJSON CalendarDate where instance ToJSON CalendarDate where toJSON = genericToJSON (aesonOptions "caldate") -data Trip (deep :: Depth) = Trip +data Trip (deep :: Depth) (shape :: Depth)= Trip { tripRoute :: Text , tripTripID :: TripID , tripHeadsign :: Maybe Text @@ -199,18 +199,21 @@ data Trip (deep :: Depth) = Trip , tripServiceId :: Text -- , tripWheelchairAccessible :: Bool -- , tripBikesAllowed :: Bool - , tripShape :: Switch deep Shape Text + , tripShape :: Switch shape Shape Text , tripStops :: Optional deep (Vector (Stop deep)) } deriving Generic -deriving instance Show (Trip Shallow) -deriving instance Show (Trip Deep) -instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d)))) => FromJSON (Trip d) where +deriving instance Show (Trip Shallow Shallow) +deriving instance Show (Trip Deep Deep) +deriving instance Show (Trip Deep Shallow) +instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d))), FromJSON (Switch s Shape Text)) => FromJSON (Trip d s) where parseJSON = genericParseJSON (aesonOptions "trip") -instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d)))) => ToJSON (Trip d) where +instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d))), ToJSON (Switch s Shape Text)) => ToJSON (Trip d s) where toJSON = genericToJSON (aesonOptions "trip") -instance ToSchema (Trip Deep) where +instance ToSchema (Trip Deep Deep) where + declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip") +instance ToSchema (Trip Deep Shallow) where declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip") -- | helper function to find things in Vectors of things @@ -297,7 +300,7 @@ instance CSV.FromNamedRecord CalendarDate where _ -> fail $ "unexpected value in exception_type: "+|int|+"." -instance CSV.FromNamedRecord (Trip Shallow) where +instance CSV.FromNamedRecord (Trip Shallow Shallow) where parseNamedRecord r = Trip <$> r .: "route_id" <*> r .: "trip_id" @@ -314,7 +317,7 @@ instance CSV.FromNamedRecord (Trip Shallow) where data RawGTFS = RawGTFS { rawStations :: Vector Station , rawStops :: Vector (Stop Shallow) - , rawTrips :: Vector (Trip Shallow) + , rawTrips :: Vector (Trip Shallow Shallow) , rawCalendar :: Maybe (Vector Calendar) , rawCalendarDates :: Maybe (Vector CalendarDate) , rawShapePoints :: Maybe (Vector ShapePoint) @@ -323,12 +326,12 @@ data RawGTFS = RawGTFS data GTFS = GTFS { stations :: Map StationID Station - , trips :: Map TripID (Trip Deep) + , trips :: Map TripID (Trip Deep Deep) , calendar :: Map DayOfWeek (Vector Calendar) , calendarDates :: Map Day (Vector CalendarDate) , shapes :: Map Text Shape - , fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep)) + , fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep Deep)) -- ^ a more "fancy" encoding of the calendar? } -- deriving Show @@ -400,7 +403,7 @@ loadGtfs path = do Just a -> pure a Nothing -> fail $ "station with id "+|stopStation stop|+"is mentioned but not defined." pure $ stop { stopStation = station } - pushTrip :: Vector (Stop Deep) -> Map Text Shape -> Trip Shallow -> IO (Trip Deep) + pushTrip :: Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep) pushTrip stops shapes trip = if V.length alongRoute < 2 then fail $ "trip with id "+|tripTripID trip|+" has no stops" else do @@ -430,7 +433,7 @@ servicesOnDay GTFS{..} day = notCancelled serviceID = null (tableLookup caldateServiceId serviceID removed) -tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep) +tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep Deep) tripsOfService GTFS{..} serviceId = M.filter (\trip -> tripServiceId trip == serviceId ) trips @@ -440,5 +443,5 @@ tripsAtStation GTFS{..} at = fmap stopTrip stops where stops = V.filter (\(stop :: Stop Deep) -> stationId (stopStation stop) == at) stops -tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep) +tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep) tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today) diff --git a/lib/Persist.hs b/lib/Persist.hs index 4a6d9b4..552074f 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -78,10 +78,15 @@ TripPing json sql=tt_trip_ping timestamp UTCTime deriving Show Generic Eq -Announcements sql=tt_announcements +-- TODO: multi-language support? +Announcement sql=tt_announcements + Id UUID default=uuid_generate_v4() trip TripID message Text - day Text + header Text + day Day + url Text Maybe + announcedAt UTCTime Maybe -- | this table works as calendar_dates.txt in GTFS ScheduleAmendment json sql=tt_schedule_amendement 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 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 + } diff --git a/todo.org b/todo.org index 7140bf3..363aa2d 100644 --- a/todo.org +++ b/todo.org @@ -6,13 +6,17 @@ * TODO Handle service announcements (per trip & day, nothing else needs to be supported) * TODO allow trip ping ingest via websockets -* IDLE somehow handle extra data (e.g. track kilometres) without polluting the GTFS * TODO implement GTFS realtime (this actually doesn't look too bad?) -** TODO do the protobuf stuff +** DONE do the protobuf stuff ** TODO implement rest of stuff * TODO find out if we need to support VDV standards * TODO do lots and lots of testing +* IDLE frontend stuff ("leitstelle") +* IDLE tracker stuff (as website) +* IDLE monitoring stuff (at least a grafana with trains would be nice) +* IDLE somehow handle extra data (e.g. track kilometres) without polluting the GTFS +- same for "how do we know how much we can reduce delay between stops?" diff --git a/tracktrain.cabal b/tracktrain.cabal index 7c20efe..2fe51c2 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -26,7 +26,7 @@ executable tracktrain build-depends: base ^>=4.14.3.0 , bytestring >= 0.10.10.0 , fmt >= 0.6.3.0 - , time >= 1.9 + , time >= 1.11 , aeson , tracktrain , wai-extra @@ -65,7 +65,7 @@ library , regex-tdfa , text , fmt >= 0.6.3.0 - , time >= 1.9 + , time >= 1.11 , aeson , servant , servant-server @@ -92,6 +92,7 @@ library hs-source-dirs: lib exposed-modules: GTFS , Server + , Server.GTFSRT , PersistOrphans , Persist , API -- cgit v1.2.3