restructure: have "tickets" independent of gtfs

this is mostly meant to guard against the gtfs changing under
tracktrain, and not yet complete (e.g. a ticket does not yet save its
expected stops, which it probably should).

8 files changed, 305 insertions, 192 deletions

diff --git a/lib/API.hs b/lib/API.hs
index b18ebdd..ab04a53 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -63,20 +63,20 @@ instance ToSchema Value where
 
 -- | 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 Deep))
+  :<|> "timetable" :> Capture "Station Id" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripId (Trip Deep Deep))
   :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value
-  :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (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 :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
+  :<|> "train" :> "register" :> Capture "Ticket Id" UUID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
   -- TODO: perhaps a websocket instead?
   :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
   :<|> "train" :> "ping" :> "ws" :> WebSocket
-  :<|> "train" :> "subscribe" :> Capture "Trip ID" TripID :> Capture "Day" Day :> WebSocket
+  :<|> "train" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
   -- debug things
   :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
-  :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
-  :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
+  :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing]
+  :<|> "debug" :> "register" :> Capture "Ticket Id" UUID :> Post '[JSON] Token
   :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile
   :<|> "gtfs" :> GtfsRealtimeAPI
 
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 6a2d88a..8edcc25 100644
--- a/lib/Extrapolation.hs
+++ b/lib/Extrapolation.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE RecordWildCards     #-}
 
@@ -24,8 +23,8 @@ import           GTFS               (Depth (Deep), GTFS (..), Seconds (..),
                                      Shape (..), Station (stationName),
                                      Stop (..), Time, Trip (..), seconds2Double,
                                      stationGeopos, toSeconds)
-import           Persist            (Running (..), TrainAnchor (..),
-                                     TrainPing (..))
+import           Persist            (Ticket (..), Token (..), Tracker (..),
+                                     TrainAnchor (..), TrainPing (..))
 import           Server.Util        (utcToSeconds)
 
 -- | Determines how to extrapolate delays (and potentially other things) from the real-time
@@ -33,7 +32,7 @@ import           Server.Util        (utcToSeconds)
 -- TODO: maybe split into two classes?
 class Extrapolator a where
   -- | here's a position ping, guess things from that!
-  extrapolateAnchorFromPing :: a -> GTFS -> Running -> TrainPing -> TrainAnchor
+  extrapolateAnchorFromPing :: a -> GTFS -> Ticket -> TrainPing -> TrainAnchor
 
   -- | extrapolate status at some time (i.e. "how much delay does the train have *now*?")
   extrapolateAtSeconds :: a -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor
@@ -47,7 +46,7 @@ instance Extrapolator LinearExtrapolator where
   extrapolateAtSeconds _ history secondsNow =
     fmap (minimumBy (compare `on` difference))
     $ NE.nonEmpty $ NE.filter (\a -> trainAnchorWhen a < secondsNow) history
-    where difference status = secondsNow - (trainAnchorWhen status)
+    where difference status = secondsNow - trainAnchorWhen status
 
   -- note that this sorts (descending) for time first as a tie-breaker
   -- (in case the train just stands still for a while, take the most recent update)
@@ -55,19 +54,18 @@ instance Extrapolator LinearExtrapolator where
     fmap (minimumBy (compare `on` difference))
     $ NE.nonEmpty $ sortOn (Down . trainAnchorWhen)
     $ NE.filter (\a -> trainAnchorSequence a < positionNow) history
-    where difference status = positionNow - (trainAnchorSequence status)
+    where difference status = positionNow - trainAnchorSequence status
 
-  extrapolateAnchorFromPing _ gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor
+  extrapolateAnchorFromPing _ gtfs@GTFS{..} Ticket{..} ping@TrainPing{..} = TrainAnchor
     { trainAnchorCreated = trainPingTimestamp
-    , trainAnchorTrip = runningTrip
-    , trainAnchorDay = runningDay
-    , trainAnchorWhen = utcToSeconds trainPingTimestamp runningDay
+    , trainAnchorTicket = trainPingTicket
+    , trainAnchorWhen = utcToSeconds trainPingTimestamp ticketDay
     , trainAnchorSequence
     , trainAnchorDelay
     , trainAnchorMsg = Nothing
     }
-    where Just trip = M.lookup runningTrip trips
-          (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping runningDay
+    where Just trip = M.lookup ticketTrip trips
+          (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping ticketDay
 
 linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double)
 linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, observedSequence)
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 6d8bcc5..c4652e8 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -193,7 +193,7 @@ type family Optional c a where
   Optional Shallow _ = ()
 
 type StationID = Text
-type TripID = Text
+type TripId = Text
 type ServiceID = Text
 
 
@@ -218,7 +218,7 @@ stationGeopos Station{..} = (stationLat, stationLon)
 
 -- | This is what's called a stop time in GTFS
 data Stop (deep :: Depth) = Stop
-  { stopTrip      :: TripID
+  { stopTrip      :: TripId
   , stopArrival   :: Switch deep Time RawTime
   , stopDeparture :: Switch deep Time RawTime
   , stopStation   :: Switch deep Station StationID
@@ -274,7 +274,7 @@ instance FromForm CalendarDate
 
 data Trip (deep :: Depth) (shape :: Depth)= Trip
   { tripRoute     :: Switch deep (Route Deep) Text
-  , tripTripID    :: TripID
+  , tripTripId    :: TripId
   , tripHeadsign  :: Maybe Text
   , tripShortName :: Maybe Text
   , tripDirection :: Maybe Bool
@@ -487,7 +487,7 @@ data RawGTFS = RawGTFS
 
 data GTFS = GTFS
   { stations      :: Map StationID Station
-  , trips         :: Map TripID (Trip Deep Deep)
+  , trips         :: Map TripId (Trip Deep Deep)
   , calendar      :: Map DayOfWeek (Vector Calendar)
   , calendarDates :: Map Day (Vector CalendarDate)
   , shapes        :: Map Text Shape
@@ -549,7 +549,7 @@ loadGtfs path zoneinforoot = do
     trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips
     pure $ GTFS
       { stations = mapFromVector stationId rawStations
-      , trips = mapFromVector tripTripID trips'
+      , trips = mapFromVector tripTripId trips'
       , calendar =
         fmap V.fromList
         $ M.fromListWith (<>)
@@ -591,18 +591,18 @@ loadGtfs path zoneinforoot = do
                     , stopArrival = unRawTime (stopArrival stop) tzseries tzname }
       pushTrip :: Map Text (Route Deep) -> Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep)
       pushTrip routes stops shapes trip = if V.length alongRoute < 2
-          then fail $ "trip with id "+|tripTripID trip|+" has no stops"
+          then fail $ "trip with id "+|tripTripId trip|+" has no stops"
           else do
             shape <- case M.lookup (tripShape trip) shapes of
-              Nothing -> fail $ "trip with id "+|tripTripID trip|+" mentions a shape that does not exist."
+              Nothing -> fail $ "trip with id "+|tripTripId trip|+" mentions a shape that does not exist."
               Just shape -> pure shape
             route <- case M.lookup (tripRoute trip) routes of
-              Nothing -> fail $ "trip with id "+|tripTripID trip|+" specifies a route_id which does not exist."
+              Nothing -> fail $ "trip with id "+|tripTripId trip|+" specifies a route_id which does not exist."
               Just route -> pure route
             pure $ trip { tripStops = alongRoute, tripShape = shape, tripRoute = route}
         where alongRoute =
                 V.modify (V.sortBy (compare `on` stopSequence))
-                $ V.filter (\s -> stopTrip s == tripTripID trip) stops
+                $ V.filter (\s -> stopTrip s == tripTripId trip) stops
       pushRoute :: Vector (Agency Deep) -> Route Shallow -> IO (Route Deep)
       pushRoute agencies route = case routeAgency route of
         Nothing -> do
@@ -636,27 +636,27 @@ servicesOnDay GTFS{..} day =
         notCancelled serviceID =
           null (tableLookup caldateServiceId serviceID removed)
 
-tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep Deep)
+tripsOfService :: GTFS -> ServiceID -> Map TripId (Trip Deep Deep)
 tripsOfService GTFS{..} serviceId =
   M.filter (\trip -> tripServiceId trip == serviceId ) trips
 
 -- TODO: this should filter out trips ending there
-tripsAtStation :: GTFS -> StationID -> Vector TripID
+tripsAtStation :: GTFS -> StationID -> Vector TripId
 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 Deep)
+tripsOnDay :: GTFS -> Day -> Map TripId (Trip Deep Deep)
 tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today)
 
-runsOnDay :: GTFS -> TripID -> Day -> Bool
+runsOnDay :: GTFS -> TripId -> Day -> Bool
 runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day
-  where same Trip{..} = tripTripID == trip
+  where same Trip{..} = tripTripId == trip
 
-runsToday :: MonadIO m => GTFS -> TripID -> m Bool
+runsToday :: MonadIO m => GTFS -> TripId -> m Bool
 runsToday gtfs trip = do
   today <- liftIO getCurrentTime <&> utctDay
   pure (runsOnDay gtfs trip today)
 
 tripName :: Trip a b -> Text
-tripName Trip{..} = fromMaybe tripTripID tripShortName
+tripName Trip{..} = fromMaybe tripTripId tripShortName
diff --git a/lib/MultiLangText.hs b/lib/MultiLangText.hs
new file mode 100644
index 0000000..4cd3fc3
--- /dev/null
+++ b/lib/MultiLangText.hs
@@ -0,0 +1,12 @@
+
+-- | simple translated text
+module MultiLangText (MultiLangText, monolingual) where
+
+import           Data.Map              (Map, singleton)
+import           Data.Text             (Text)
+import           Text.Shakespeare.I18N (Lang)
+
+type MultiLangText = Map Lang Text
+
+monolingual :: Lang -> Text -> MultiLangText
+monolingual = singleton
diff --git a/lib/Persist.hs b/lib/Persist.hs
index cd77b7a..b52d7c6 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -29,6 +29,7 @@ import           Control.Monad.IO.Class      (MonadIO (liftIO))
 import           Control.Monad.Logger        (NoLoggingT)
 import           Control.Monad.Reader        (ReaderT)
 import           Data.Data                   (Proxy (..))
+import           Data.Map                    (Map)
 import           Data.Pool                   (Pool)
 import           Data.Time                   (NominalDiffTime, TimeOfDay,
                                               UTCTime (utctDay), addUTCTime,
@@ -39,7 +40,9 @@ import           Data.Vector                 (Vector)
 import           Database.Persist.Postgresql (SqlBackend)
 import           Fmt
 import           GHC.Generics                (Generic)
+import           MultiLangText               (MultiLangText)
 import           Web.PathPieces              (PathPiece)
+import           Yesod                       (Lang)
 
 
 newtype Token = Token UUID
@@ -54,28 +57,38 @@ instance ToParamSchema Token where
 
 deriving newtype instance PersistField Seconds
 deriving newtype instance PersistFieldSql Seconds
--- deriving newtype instance PathPiece Seconds
--- deriving newtype instance ToParamSchema Seconds
-
-data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int
-  deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
-derivePersistField "AmendmentStatus"
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Ticket sql=tt_ticket
+  Id UUID default=uuid_generate_v4()
+  trip TripId
+  day Day
+  imported UTCTime
+  schedule_version ImportId Maybe
+  vehicle Text Maybe
+
+Import sql=tt_imports
+  url Text
+  date UTCTime
+
 -- | tokens which have been issued
-Running sql=tt_tracker_token
+Tracker sql=tt_tracker_token
   Id Token default=uuid_generate_v4()
   expires UTCTime
   blocked Bool
-  trip Text
-  day Day
-  vehicle Text Maybe
   agent Text
   deriving Eq Show Generic
 
+TrackerTicket
+  ticket TicketId
+  tracker TrackerId
+  UniqueTrackerTicket ticket tracker
+
+
 -- raw frames as received from OBUs
 TrainPing json sql=tt_trip_ping
-  token RunningId
+  ticket TicketId
+  token TrackerId
   lat Double
   long Double
   timestamp UTCTime
@@ -84,36 +97,28 @@ TrainPing json sql=tt_trip_ping
 -- status of a train somewhen in time (may be in the future),
 -- inferred from trainpings / entered via controlRoom
 TrainAnchor json sql=tt_trip_anchor
-  trip TripID
-  day Day
+  ticket TicketId
   created UTCTime
   when Seconds
   sequence Double
   delay Seconds
-  msg Text Maybe
+  msg MultiLangText Maybe
   deriving Show Generic Eq
 
 -- TODO: multi-language support?
 Announcement json sql=tt_announcements
   Id UUID default=uuid_generate_v4()
-  trip TripID
+  ticket TicketId
   header Text
   message Text
-  day Day
   url Text Maybe
   announcedAt UTCTime Maybe
   deriving Generic Show
-
--- | this table works as calendar_dates.txt in GTFS
-ScheduleAmendment json sql=tt_schedule_amendement
-  trip TripID
-  day Day
-  status AmendmentStatus
-  -- only one special rule per TripID and Day (else incoherent)
-  TripAndDay trip day
 |]
 
-instance ToSchema RunningId where
+instance ToSchema TicketId where
+  declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
+instance ToSchema TrackerId where
   declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
 instance ToSchema TrainPing where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing")
diff --git a/lib/Server.hs b/lib/Server.hs
index 016707b..c6d2d94 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,8 +1,9 @@
-{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE ExplicitNamespaces #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE OverloadedLists    #-}
-{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE ExplicitNamespaces    #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards       #-}
 
 
 -- Implementation of the API. This module is the main point of the program.
@@ -16,8 +17,8 @@ import           Control.Monad.Catch         (handle)
 import           Control.Monad.Extra         (ifM, maybeM, unlessM, whenJust,
                                               whenM)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
-import           Control.Monad.Logger        (LoggingT, logWarnN)
-import           Control.Monad.Reader        (forM)
+import           Control.Monad.Logger        (LoggingT, NoLoggingT, logWarnN)
+import           Control.Monad.Reader        (ReaderT, forM)
 import           Control.Monad.Trans         (lift)
 import           Data.Aeson                  ((.=))
 import qualified Data.Aeson                  as A
@@ -61,9 +62,11 @@ import           Extrapolation               (Extrapolator (..),
                                               LinearExtrapolator (..))
 import           System.IO.Unsafe
 
+import           Conduit                     (ResourceT)
 import           Config                      (ServerConfig (serverConfigAssets))
 import           Data.ByteString             (ByteString)
 import           Data.ByteString.Lazy        (toStrict)
+import           Data.UUID                   (UUID)
 import           Prometheus
 import           Prometheus.Metric.GHC
 
@@ -83,7 +86,7 @@ doMigration pool = runSql pool $
   -- returns an empty list
   runMigration migrateAll
 
-server :: GTFS -> Metrics -> TVar (M.Map TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
+server :: GTFS -> Metrics -> TVar (M.Map UUID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
 server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
   :<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip
         :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
@@ -101,7 +104,7 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
           pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day
           where mkJson :: Trip Deep Deep -> A.Value
                 mkJson Trip {..} = A.object
-                  [ "trip" .= tripTripID
+                  [ "trip" .= tripTripId
                   , "sequencelength" .= (stopSequence . V.last) tripStops
                   , "stops" .= fmap (\Stop{..} -> A.object
                     [ "departure" .= toUTC stopDeparture tzseries day
@@ -114,34 +117,35 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
         handleTrip trip = case M.lookup trip trips of
           Just res -> pure res
           Nothing  -> throwError err404
-        handleRegister tripID RegisterJson{..} = do
+        handleRegister (ticketId :: UUID) RegisterJson{..} = do
           today <- liftIO getCurrentTime <&> utctDay
-          unless (runsOnDay gtfs tripID today)
-            $ sendErrorMsg "this trip does not run today."
           expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
-          RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent)
-          pure token
-        handleDebugRegister tripID day = do
+          runSql dbpool $ do
+            TrackerKey tracker <- insert (Tracker expires False registerAgent)
+            insert (TrackerTicket (TicketKey ticketId) (TrackerKey tracker))
+            pure tracker
+        handleDebugRegister (ticketId :: UUID) = do
           expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
-          RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key")
-          pure token
-        handleTrainPing onError ping = isTokenValid dbpool (coerce $ trainPingToken ping) >>= \case
+          runSql dbpool $ do
+            TrackerKey tracker <- insert (Tracker expires False "debug key")
+            insert (TrackerTicket (TicketKey ticketId) (TrackerKey tracker))
+            pure tracker
+        handleTrainPing onError ping@TrainPing{..} = isTokenValid dbpool trainPingToken trainPingTicket
+          >>= \case
           Nothing -> do
             onError
             pure Nothing
-          Just running@Running{..} -> do
-            let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs running ping
+          Just (tracker@Tracker{..}, ticket@Ticket{..}) -> do
+            let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs ticket ping
             -- TODO: are these always inserted in order?
             runSql dbpool $ do
               insert ping
-              last <- selectFirst
-                [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay]
-                [Desc TrainAnchorWhen]
+              last <- selectFirst [TrainAnchorTicket ==. trainPingTicket] [Desc TrainAnchorWhen]
               -- only insert new estimates if they've actually changed anything
               when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor))
                 $ void $ insert anchor
             queues <- liftIO $ atomically $ do
-              queues <- readTVar subscribers <&> M.lookup runningTrip
+              queues <- readTVar subscribers <&> M.lookup (coerce trainPingTicket)
               whenJust queues $
                 mapM_ (\q -> writeTQueue q (Just ping))
               pure queues
@@ -162,18 +166,18 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
                 liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case
                   Just anchor -> WS.sendTextData conn (A.encode anchor)
                   Nothing     -> pure ()
-        handleSubscribe tripId day conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
+        handleSubscribe (ticketId :: UUID) conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
           queue <- atomically $ do
             queue <- newTQueue
             qs <- readTVar subscribers
             writeTVar subscribers
-              $ M.insertWith (<>) tripId [queue] qs
+              $ M.insertWith (<>) ticketId [queue] qs
             pure queue
           -- send most recent ping, if any (so we won't have to wait for movement)
           lastPing <- runSql dbpool $ do
-            tokens <- selectList [RunningDay ==. day, RunningTrip ==. tripId] []
+            trackers <- getTicketTrackers ticketId
               <&> fmap entityKey
-            selectFirst [TrainPingToken <-. tokens] [Desc TrainPingTimestamp]
+            selectFirst [TrainPingToken <-. trackers] [Desc TrainPingTimestamp]
               <&> fmap entityVal
           whenJust lastPing $ \ping ->
             WS.sendTextData conn (A.encode lastPing)
@@ -187,34 +191,39 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
             where removeSubscriber queue = atomically $ do
                     qs <- readTVar subscribers
                     writeTVar subscribers
-                     $ M.adjust (filter (/= queue)) tripId qs
+                     $ M.adjust (filter (/= queue)) ticketId qs
         handleDebugState = do
           now <- liftIO getCurrentTime
           runSql dbpool $ do
-           running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] []
-           pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> do
+           tracker <- selectList [TrackerBlocked ==. False, TrackerExpires >=. now] []
+           pairs <- forM tracker $ \(Entity token@(TrackerKey uuid) _) -> do
              entities <- selectList [TrainPingToken ==. token] []
              pure (uuid, fmap entityVal entities)
            pure (M.fromList pairs)
-        handleDebugTrain tripId day = do
-          unless (runsOnDay gtfs tripId day)
-            $ sendErrorMsg ("this trip does not run on "+|day|+".")
+        handleDebugTrain ticketId = do
           runSql dbpool $ do
-            tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] []
-            pings <- forM tokens $ \(Entity token _) -> do
+            trackers <- getTicketTrackers ticketId
+            pings <- forM trackers $ \(Entity token _) -> do
               selectList [TrainPingToken ==. token] [] <&> fmap entityVal
             pure (concat pings)
         handleDebugAPI = pure $ toSwagger (Proxy @API)
         metrics = exportMetricsAsText <&> (decodeUtf8 . toStrict)
 
+getTicketTrackers :: UUID -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Entity Tracker]
+getTicketTrackers ticketId = do
+  joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] []
+           <&> fmap (trackerTicketTracker . entityVal)
+  selectList [TrackerId <-. joins] []
+
 
 -- TODO: proper debug logging for expired tokens
-isTokenValid :: MonadIO m => Pool SqlBackend -> Token -> m (Maybe Running)
-isTokenValid dbpool token = runSql dbpool $ get (coerce token) >>= \case
-  Just trip | not (runningBlocked trip) -> do
-    ifM (hasExpired (runningExpires trip))
+isTokenValid :: MonadIO m => Pool SqlBackend -> TrackerId -> TicketId -> m (Maybe (Tracker, Ticket))
+isTokenValid dbpool token ticketId = runSql dbpool $ get token >>= \case
+  Just tracker | not (trackerBlocked tracker) -> do
+    ifM (hasExpired (trackerExpires tracker))
       (pure Nothing)
-      (pure (Just trip))
+      $ runSql dbpool $ get ticketId
+       <&> (\case { Nothing -> Nothing; Just ticket -> Just (tracker, ticket) })
   _ -> pure Nothing
 
 hasExpired :: MonadIO m => UTCTime -> m Bool
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 773468a..4fb5ba8 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,16 +1,17 @@
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DefaultSignatures     #-}
-{-# LANGUAGE DeriveAnyClass        #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeFamilies      #-}
 
 module Server.ControlRoom (ControlRoom(..)) where
 
-import           Control.Monad             (forM_, join)
+import           Config                    (ServerConfig (..), UffdConfig (..))
+import           Control.Monad             (forM, forM_, join)
 import           Control.Monad.Extra       (maybeM)
 import           Control.Monad.IO.Class    (MonadIO (liftIO))
 import qualified Data.Aeson                as A
@@ -21,6 +22,7 @@ import           Data.List                 (lookup)
 import           Data.List.NonEmpty        (nonEmpty)
 import           Data.Map                  (Map)
 import qualified Data.Map                  as M
+import           Data.Maybe                (catMaybes, fromJust)
 import           Data.Pool                 (Pool)
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
@@ -35,9 +37,14 @@ import           Database.Persist          (Entity (..), delete, entityVal, get,
                                             insert, selectList, (==.))
 import           Database.Persist.Sql      (PersistFieldSql, SqlBackend,
                                             runSqlPool)
+import           Extrapolation             (Extrapolator (..),
+                                            LinearExtrapolator (..))
 import           Fmt                       ((+|), (|+))
 import           GHC.Float                 (int2Double)
 import           GHC.Generics              (Generic)
+import           GTFS
+import           Numeric                   (showFFloat)
+import           Persist
 import           Server.Util               (Service, secondsNow)
 import           Text.Blaze.Html           (ToMarkup (..))
 import           Text.Blaze.Internal       (MarkupM (Empty))
@@ -46,16 +53,9 @@ import           Text.Shakespeare.Text
 import           Yesod
 import           Yesod.Auth
 import           Yesod.Auth.OAuth2.Prelude
-import           Yesod.Form
-
-import           Config                    (ServerConfig (..), UffdConfig (..))
-import           Extrapolation             (Extrapolator (..),
-                                            LinearExtrapolator (..))
-import           GTFS
-import           Numeric                   (showFFloat)
-import           Persist
 import           Yesod.Auth.OpenId         (IdentifierType (..), authOpenId)
 import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)
+import           Yesod.Form
 import           Yesod.Orphans             ()
 
 
@@ -71,15 +71,16 @@ mkYesod "ControlRoom" [parseRoutes|
 / RootR GET
 /auth AuthR Auth getAuth
 /trains TrainsR GET
-/train/id/#TripID/#Day TrainViewR GET
-/train/map/#TripID/#Day TrainMapViewR GET
-/train/announce/#TripID/#Day AnnounceR POST
+/train/id/#UUID TicketViewR GET
+/train/import/#Day TicketImportR POST
+/train/map/#UUID TrainMapViewR GET
+/train/announce/#UUID AnnounceR POST
 /train/del-announce/#UUID DelAnnounceR GET
 /token/block/#Token TokenBlock GET
 /trips TripsViewR GET
-/trip/#TripID TripViewR GET
+/trip/#TripId TripViewR GET
 /obu OnboardUnitMenuR GET
-/obu/#TripID/#Day OnboardUnitR GET
+/obu/#TripId/#Day OnboardUnitR GET
 |]
 
 emptyMarkup :: MarkupM a -> Bool
@@ -191,7 +192,17 @@ getTrainsR = do
   let prevday = (T.pack . iso8601Show . addDays (-1))  day
   let nextday = (T.pack . iso8601Show . addDays 1) day
   gtfs <- getYesod <&> getGtfs
+
+  -- TODO: tickets should have all trip information saved
+  tickets <- runDB $ selectList [ TicketDay ==. day ] []
+    <&> fmap (\(Entity (TicketKey ticketId) ticket) ->
+                (ticketId, ticket, fromJust $ M.lookup (ticketTrip ticket) (trips gtfs)))
+
   let trips = tripsOnDay gtfs day
+  let headsign (Trip{..} :: Trip Deep Deep) = case tripHeadsign of
+        Just headsign -> headsign
+        Nothing       -> stationName (stopStation (V.last tripStops))
+  (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
   defaultLayout $ do
     [whamlet|
 <h1> _{MsgTrainsOnDay (iso8601Show day)}
@@ -205,38 +216,71 @@ $maybe name <- mdisplayname
     <a href="@{TrainsR}">_{Msgtoday}
   <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
 <section>
+  <h2>_{MsgTickets}
   <ol>
-   $forall trip@Trip{..} <- trips
-    <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a>
-         : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
-   $if null trips
+   $forall (ticketId, Ticket{..}, trip@Trip{..}) <- tickets
+    <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{tripName trip}</a>
+         : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip}
+   $if null tickets
      <li style="text-align: center"><em>(_{MsgNone})
+<section>
+  <h2>_{MsgAccordingToGtfs}
+  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgImportTrips}
 |]
 
-getTrainViewR :: TripID -> Day -> Handler Html
-getTrainViewR trip day = do
+postTicketImportR :: Day -> Handler Html
+postTicketImportR day = do
+  gtfs <- getYesod <&> getGtfs
+  let trips = tripsOnDay gtfs day
+  ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+  case result of
+    FormSuccess selected -> do
+      now <- liftIO getCurrentTime
+      let tickets = flip fmap selected $ \(Trip{..}, day) -> Ticket
+            { ticketTrip = tripTripId, ticketDay = day, ticketImported = now
+            , ticketSchedule_version = Nothing, ticketVehicle = Nothing }
+      runDB $ insertMany tickets
+      redirect (TrainsR, [("day", T.pack (iso8601Show day))])
+    _ -> defaultLayout [whamlet|
+<section>
+  <h2>_{MsgAccordingToGtfs}
+  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId)
+     >>= \case {Nothing -> notFound; Just a -> pure a}
+
   GTFS{..} <- getYesod <&> getGtfs
-  (widget, enctype) <- generateFormPost (announceForm day trip)
-  case M.lookup trip trips of
+  (widget, enctype) <- generateFormPost (announceForm ticketId)
+  case M.lookup ticketTrip trips of
     Nothing -> notFound
     Just res@Trip{..} -> do
-      anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
-      tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
-      lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
-      anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
+      let ticketKey = TicketKey ticketId
+      anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+      trackerIds <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+        <&> fmap (trackerTicketTracker . entityVal)
+      trackers <- runDB $ selectList [ TrackerId <-. trackerIds ] [Asc TrackerExpires]
+      lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
+      anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
         <&> nonEmpty . fmap entityVal
-      nowSeconds <- secondsNow day
+      nowSeconds <- secondsNow ticketDay
       defaultLayout $ do
         mr <- getMessageRender
-        setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
+        setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripId|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
         [whamlet|
-<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
+<h1>_{MsgTrip} <a href="@{TripViewR tripTripId}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}</a>
 <section>
   <h2>_{MsgLive}
   <p><strong>_{MsgLastPing}: </strong>
     $maybe Entity _ TrainPing{..} <- lastPing
       _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
-      (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
+      (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
     $nothing
       <em>(_{MsgNoTrainPing})
   <p><strong>_{MsgEstimatedDelay}</strong>:
@@ -245,7 +289,7 @@ getTrainViewR trip day = do
         \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
     $nothing
       <em> (_{MsgNone})
-  <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
+  <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a>
 <section>
   <h2>_{MsgStops}
   <ol>
@@ -262,21 +306,21 @@ getTrainViewR trip day = do
     $if null anns
       <li><em>(_{MsgNone})</em>
   <h3>_{MsgNewAnnouncement}
-  <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+  <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
     ^{widget}
     <button>_{MsgSubmit}
 <section>
   <h2>_{MsgTokens}
   <table>
     <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
-    $if null tokens
+    $if null trackers
       <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
-    $forall Entity (RunningKey key) Running{..} <- tokens
-      <tr :runningBlocked:.blocked>
-        <td title="#{runningAgent}">#{runningAgent}
+    $forall Entity (TrackerKey key) Tracker{..} <- trackers
+      <tr :trackerBlocked:.blocked>
+        <td title="#{trackerAgent}">#{trackerAgent}
         <td title="#{key}">#{key}
-        <td title="#{runningExpires}">#{runningExpires}
-        $if runningBlocked
+        <td title="#{trackerExpires}">#{trackerExpires}
+        $if trackerBlocked
           <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
         $else
           <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
@@ -285,14 +329,16 @@ getTrainViewR trip day = do
                 guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
 
 
-getTrainMapViewR :: TripID -> Day -> Handler Html
-getTrainMapViewR tripId day = do
+getTrainMapViewR :: UUID -> Handler Html
+getTrainMapViewR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId)
+    >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
   GTFS{..} <- getYesod <&> getGtfs
-  (widget, enctype) <- generateFormPost (announceForm day tripId)
-  case M.lookup tripId trips of
+  (widget, enctype) <- generateFormPost (announceForm ticketId)
+  case M.lookup ticketTrip trips of
     Nothing -> notFound
     Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a>
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a>
 <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
      integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
      crossorigin=""/>
@@ -308,7 +354,7 @@ getTrainMapViewR tripId day = do
       attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
   }).addTo(map);
 
-  ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripID}/#{day}");
+  ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripId}/#{ticketDay}");
 
   var marker = null;
 
@@ -336,12 +382,12 @@ getTripsViewR = do
 <h1>List of Trips
 <section><ul>
   $forall trip@Trip{..} <- trips
-    <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a>
+    <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a>
       : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
 |]
 
 
-getTripViewR :: TripID -> Handler Html
+getTripViewR :: TripId -> Handler Html
 getTripViewR tripId = do
   GTFS{..} <- getYesod <&> getGtfs
   case M.lookup tripId trips of
@@ -350,7 +396,7 @@ getTripViewR tripId = do
 <h1>_{MsgTrip} #{tripName trip}
 <section>
   <h2>_{MsgInfo}
-  <p><strong>_{MsgtripId}:</strong> #{tripTripID}
+  <p><strong>_{MsgtripId}:</strong> #{tripTripId}
   <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
   <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
 <section>
@@ -365,17 +411,17 @@ getTripViewR tripId = do
 |]
 
 
-postAnnounceR :: TripID -> Day -> Handler Html
-postAnnounceR trip day = do
-    ((result, widget), enctype) <- runFormPost (announceForm day trip)
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+    ((result, widget), enctype) <- runFormPost (announceForm ticketId)
     case result of
         FormSuccess ann -> do
           runDB $ insert ann
-          redirect (TrainViewR trip day)
+          redirect RootR -- (TicketViewR trip day)
         _ -> defaultLayout
             [whamlet|
                 <p>_{MsgInvalidInput}.
-                <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+                <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
                     ^{widget}
                     <button>_{MsgSubmit}
             |]
@@ -389,19 +435,20 @@ getDelAnnounceR uuid = do
   case ann of
     Nothing -> notFound
     Just Announcement{..} ->
-      redirect (TrainViewR announcementTrip announcementDay)
+      let (TicketKey ticketId) = announcementTicket
+      in redirect (TicketViewR ticketId)
 
 getTokenBlock :: Token -> Handler Html
 getTokenBlock token = do
   YesodRequest{..} <- getRequest
   let blocked = lookup "unblock" reqGetParams /= Just "true"
   maybe <- runDB $ do
-    update (RunningKey token) [ RunningBlocked =. blocked ]
-    get (RunningKey token)
+    update (TrackerKey token) [ TrackerBlocked =. blocked ]
+    get (TrackerKey token)
   case maybe of
-    Just r@Running{..} -> do
+    Just r@Tracker{..} -> do
       liftIO $ print r
-      redirect (TrainViewR runningTrip runningDay)
+      redirect RootR
     Nothing -> notFound
 
 getOnboardUnitMenuR :: Handler Html
@@ -416,24 +463,55 @@ getOnboardUnitMenuR = do
   _{MsgChooseTrain}
   $forall Trip{..} <- trips
     <hr>
-    <a href="@{OnboardUnitR tripTripID day}">
-      #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
+    <a href="@{OnboardUnitR tripTripId day}">
+      #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
 |]
 
-getOnboardUnitR :: TripID -> Day -> Handler Html
+getOnboardUnitR :: TripId -> Day -> Handler Html
 getOnboardUnitR tripId day =
   defaultLayout $(whamletFile "site/obu.hamlet")
 
-announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm day tripId = renderDivs $ Announcement
-  <$> pure tripId
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+  <$> pure (TicketKey ticketId)
   <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
   <*> areq textField (fieldSettingsLabel MsgText) Nothing
-  <*> pure day
   <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
   <*> lift (liftIO getCurrentTime <&> Just)
 
+
+
+tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget)
+tripImportForm trips extra = do
+  forms <- forM trips $ \(trip, day) -> do
+    (aRes, aView) <- mreq checkBoxField "import" Nothing
+    let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+    pure (trip, day, dings, aView)
+
+  let widget = toWidget [whamlet|
+     #{extra}
+     <ol>
+       $forall (trip@Trip{..}, day, res, view) <- forms
+         <li>
+           ^{fvInput view}
+           <label for="^{fvId view}">
+             _{MsgTrip} #{tripName trip}
+               : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} → #{headsign trip}
+  |]
+
+  let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) =
+        sequenceA (fmap (\(_,_,res,_) -> res) forms)
+
+  pure (fmap catMaybes a, widget)
+
+
 mightbe :: Maybe Text -> Text
 mightbe (Just a) = a
 mightbe Nothing  = ""
 
+
+headsign :: Trip 'Deep 'Deep -> Text
+headsign (Trip{..} :: Trip Deep Deep) =
+  case tripHeadsign of
+    Just headsign -> headsign
+    Nothing       -> stationName (stopStation (V.last tripStops))
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 740f71c..412284f 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TupleSections         #-}
-{-# LANGUAGE DataKinds #-}
 
 module Server.GTFS_RT (gtfsRealtimeServer) where
 
@@ -30,21 +31,22 @@ import qualified Data.UUID                   as UUID
 import qualified Data.Vector                 as V
 import           Database.Persist            (Entity (..),
                                               PersistQueryRead (selectFirst),
-                                              selectList, (==.))
+                                              getJust, selectKeysList,
+                                              selectList, (<-.), (==.))
 import           Database.Persist.Postgresql (SqlBackend)
 import           Extrapolation               (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
                                               LinearExtrapolator (..))
 import           GHC.Float                   (double2Float, int2Double)
 import           GTFS                        (Depth (..), GTFS (..),
                                               Seconds (..), Stop (..),
-                                              Trip (..), TripID,
+                                              Trip (..), TripId,
                                               showTimeWithSeconds, stationId,
                                               toSeconds, toUTC, tripsOnDay)
 import           Persist                     (Announcement (..),
                                               EntityField (..), Key (..),
-                                              Running (..), Token (..),
-                                              TrainAnchor (..), TrainPing (..),
-                                              runSql)
+                                              Ticket (..), Token (..),
+                                              Tracker (..), TrainAnchor (..),
+                                              TrainPing (..), runSql)
 import qualified Proto.GtfsRealtime          as RT
 import qualified Proto.GtfsRealtime_Fields   as RT
 import           Servant.API                 ((:<|>) (..))
@@ -70,17 +72,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
   where
     handleServiceAlerts = runSql dbpool $ do
       announcements <- selectList [] []
-      defFeedMessage (fmap mkAlert announcements)
+      alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
+        ticket <- getJust announcementTicket
+        pure $ mkAlert uuid announcement ticket
+      defFeedMessage alerts
 
       where
-        mkAlert :: Entity Announcement -> RT.FeedEntity
-        mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+        mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
+        mkAlert uuid Announcement{..} Ticket{..} =
               defMessage
               & RT.id .~ UUID.toText uuid
               & RT.alert .~ (defMessage
                   & RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
                   & RT.informedEntity .~ [ defMessage
-                       & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
+                       & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing
                     ]
                   & RT.maybe'url .~ fmap (monolingual "de") announcementUrl
                   & RT.headerText .~ monolingual "de" announcementHeader
@@ -92,7 +97,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
       nowSeconds <- secondsNow today
       let running = M.toList (tripsOnDay gtfs today)
       anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
-        entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
+        tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] []
+        entities <- selectList [TrainAnchorTicket <-. tickets] []
         case nonEmpty (fmap entityVal entities) of
           Nothing      -> pure Nothing
           Just anchors -> pure $ Just (tripId, trip, anchors)
@@ -138,18 +144,23 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
               & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
 
     handleVehiclePositions = runSql dbpool $ do
-      (running :: [Entity Running]) <- selectList [] []
-      pings <- forM running $ \(Entity key entity) -> do
-        selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
+      (trackers :: [Entity Tracker]) <- selectList [] []
+      pings <- forM trackers $ \(Entity trackerId tracker) -> do
+        selectFirst [TrainPingToken ==. trackerId] [] >>= \case
+          Nothing -> pure Nothing
+          Just ping -> do
+            ticket <- getJust (trainPingTicket (entityVal ping))
+            pure (Just (ping, ticket, tracker))
+
       defFeedMessage (mkPosition <$> catMaybes pings)
 
       where
-        mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
-        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
+        mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity
+        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage
           & RT.id .~ T.pack (show key)
           & RT.vehicle .~ (defMessage
-              & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
-              & RT.maybe'vehicle .~ case runningVehicle of
+              & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing
+              & RT.maybe'vehicle .~ case ticketVehicle of
                   Nothing -> Nothing
                   Just trainset -> Just $ defMessage
                     & RT.label .~ trainset
@@ -180,7 +191,7 @@ defFeedMessage entities = do
    )
    & RT.entity .~ entities
 
-defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
+defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor
 defTripDescriptor tripId day starttime = defMessage
   & RT.tripId .~ tripId
   & RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED