aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cabal.project.freeze277
-rw-r--r--lib/API.hs56
-rw-r--r--lib/GTFS.hs31
-rw-r--r--lib/Persist.hs9
-rw-r--r--lib/Server.hs70
-rw-r--r--lib/Server/GTFSRT.hs155
-rw-r--r--todo.org8
-rw-r--r--tracktrain.cabal5
8 files changed, 232 insertions, 379 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 09:39:07 +0000