more or less functional servicealerts for gtfs rt

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

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