restructure: save a ticket's stop in the database

now mostly independent of the gtfs, but still no live-reloading of it.

11 files changed, 508 insertions, 332 deletions

diff --git a/lib/API.hs b/lib/API.hs
index ab04a53..2c8123a 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -30,7 +30,6 @@ import           Servant.API                 (Accept, Capture, Get, JSON,
                                               Post, QueryParam, Raw, ReqBody,
                                               type (:<|>) (..))
 import           Servant.API.WebSocket       (WebSocket)
--- import           Servant.GTFS.Realtime       (Proto)
 import           Servant.Swagger             (HasSwagger (..))
 import           Web.Internal.FormUrlEncoded (Form)
 
@@ -42,7 +41,9 @@ import qualified Data.ByteString.Lazy        as LB
 import           Data.HashMap.Strict.InsOrd  (singleton)
 import           Data.ProtoLens              (Message, encodeMessage)
 import           GHC.Generics                (Generic)
-import           GTFS
+import           GTFS                        (Depth (Deep), GTFSFile (..),
+                                              StationID, Trip, TripId,
+                                              aesonOptions, swaggerOptions)
 import           Network.HTTP.Media          ((//))
 import           Persist
 import           Prometheus
@@ -62,8 +63,7 @@ instance ToSchema Value where
       & type_ ?~ SwaggerObject
 
 -- | 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))
+type API =  "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)
   -- ingress API (put this behind BasicAuth?)
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 8edcc25..01e5f6f 100644
--- a/lib/Extrapolation.hs
+++ b/lib/Extrapolation.hs
@@ -4,40 +4,52 @@
 {-# LANGUAGE RecordWildCards     #-}
 
 module Extrapolation (Extrapolator(..), LinearExtrapolator(..), linearDelay, distanceAlongLine, euclid) where
-import           Data.Foldable      (maximumBy, minimumBy)
-import           Data.Function      (on)
-import           Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map           as M
-import           Data.Time          (Day, UTCTime (UTCTime, utctDay),
-                                     diffUTCTime, getCurrentTime,
-                                     nominalDiffTimeToSeconds)
-import qualified Data.Vector        as V
-import           GHC.Float          (int2Double)
-import           GHC.IO             (unsafePerformIO)
-
-import           Conduit            (MonadIO (liftIO))
-import           Data.List          (sortBy, sortOn)
-import           Data.Ord           (Down (..))
-import           GTFS               (Depth (Deep), GTFS (..), Seconds (..),
-                                     Shape (..), Station (stationName),
-                                     Stop (..), Time, Trip (..), seconds2Double,
-                                     stationGeopos, toSeconds)
-import           Persist            (Ticket (..), Token (..), Tracker (..),
-                                     TrainAnchor (..), TrainPing (..))
-import           Server.Util        (utcToSeconds)
+import           Data.Foldable                       (maximumBy, minimumBy)
+import           Data.Function                       (on)
+import           Data.List.NonEmpty                  (NonEmpty)
+import qualified Data.List.NonEmpty                  as NE
+import qualified Data.Map                            as M
+import           Data.Time                           (Day,
+                                                      UTCTime (UTCTime, utctDay),
+                                                      diffUTCTime,
+                                                      getCurrentTime,
+                                                      nominalDiffTimeToSeconds)
+import qualified Data.Vector                         as V
+import           GHC.Float                           (int2Double)
+import           GHC.IO                              (unsafePerformIO)
+
+import           Conduit                             (MonadIO (liftIO))
+import           Data.List                           (sortBy, sortOn)
+import           Data.Ord                            (Down (..))
+import           Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
+import           GTFS                                (Seconds (..),
+                                                      seconds2Double, toSeconds)
+import           Persist                             (Geopos (..),
+                                                      ShapePoint (shapePointGeopos),
+                                                      Station (..), Stop (..),
+                                                      Ticket (..), Token (..),
+                                                      Tracker (..),
+                                                      TrainAnchor (..),
+                                                      TrainPing (..))
+import           Server.Util                         (utcToSeconds)
 
 -- | Determines how to extrapolate delays (and potentially other things) from the real-time
 -- data sent in by the OBU. Potentially useful to swap out the algorithm, or give it options.
 -- TODO: maybe split into two classes?
-class Extrapolator a where
+class Extrapolator strategy where
   -- | here's a position ping, guess things from that!
-  extrapolateAnchorFromPing :: a -> GTFS -> Ticket -> TrainPing -> TrainAnchor
+  extrapolateAnchorFromPing
+    :: strategy
+    -> Ticket
+    -> V.Vector (Stop, Station, TimeZoneSeries)
+    -> V.Vector ShapePoint
+    -> TrainPing
+    -> TrainAnchor
 
   -- | extrapolate status at some time (i.e. "how much delay does the train have *now*?")
-  extrapolateAtSeconds :: a -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor
+  extrapolateAtSeconds :: strategy -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor
   -- | extrapolate status at some places (i.e. "how much delay will it have at the next station?")
-  extrapolateAtPosition :: a -> NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor
+  extrapolateAtPosition :: strategy -> NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor
 
 
 data LinearExtrapolator = LinearExtrapolator
@@ -56,7 +68,7 @@ instance Extrapolator LinearExtrapolator where
     $ NE.filter (\a -> trainAnchorSequence a < positionNow) history
     where difference status = positionNow - trainAnchorSequence status
 
-  extrapolateAnchorFromPing _ gtfs@GTFS{..} Ticket{..} ping@TrainPing{..} = TrainAnchor
+  extrapolateAnchorFromPing _ Ticket{..} stops shape ping@TrainPing{..} = TrainAnchor
     { trainAnchorCreated = trainPingTimestamp
     , trainAnchorTicket = trainPingTicket
     , trainAnchorWhen = utcToSeconds trainPingTimestamp ticketDay
@@ -64,45 +76,55 @@ instance Extrapolator LinearExtrapolator where
     , trainAnchorDelay
     , trainAnchorMsg = Nothing
     }
-    where Just trip = M.lookup ticketTrip trips
-          (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping ticketDay
+    where
+          (trainAnchorDelay, trainAnchorSequence) = linearDelay stops shape ping ticketDay
+          tzseries = undefined
 
-linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double)
-linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, observedSequence)
-  where -- | at which sequence number is the ping?
+linearDelay :: V.Vector (Stop, Station, TimeZoneSeries) -> V.Vector ShapePoint -> TrainPing -> Day -> (Seconds, Double)
+linearDelay tripStops shape TrainPing{..} runningDay = (observedDelay, observedSequence)
+  where -- at which (fractional) sequence number is the ping?
         observedSequence = int2Double (stopSequence lastStop)
           + observedProgress * int2Double (stopSequence nextStop - stopSequence lastStop)
-        -- | how much later/earlier is the ping than would be expected?
+
+        -- how much later/earlier is the ping than would be expected?
         observedDelay = Seconds $ round $
           (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime)
+          + if expectedProgress == 1
           -- if the hypothetical on-time train is already at (or past) the next station,
           -- just add the time distance we're behind
-          + if expectedProgress /= 1 then 0
-            else seconds2Double (utcToSeconds trainPingTimestamp runningDay
-                                 - toSeconds (stopArrival nextStop) tzseries runningDay)
+          then seconds2Double (utcToSeconds trainPingTimestamp runningDay - nextSeconds)
+          -- otherwise the above is sufficient
+          else 0
 
-        -- | how far along towards the next station is the ping (between 0 and 1)?
+        -- how far along towards the next station is the ping (between 0 and 1)?
         observedProgress =
-            distanceAlongLine line (stationGeopos $ stopStation lastStop) closestPoint
-            / distanceAlongLine line (stationGeopos $ stopStation lastStop) (stationGeopos $ stopStation nextStop)
-        -- | to compare: where would a linearly-moving train be (between 0 and 1)?
+            distanceAlongLine line (stationGeopos lastStation) closestPoint
+            / distanceAlongLine line (stationGeopos lastStation) (stationGeopos nextStation)
+
+        -- to compare: where would a linearly-moving train be (between 0 and 1)?
         expectedProgress = if
           | p < 0     -> 0
           | p > 1     -> 1
           | otherwise -> p
-          where p = seconds2Double (utcToSeconds trainPingTimestamp runningDay
-                                    - toSeconds (stopDeparture lastStop) tzseries runningDay)
-                    / seconds2Double expectedTravelTime
-        -- | how long do we expect the trip from last to next station to take?
-        expectedTravelTime =
-            toSeconds (stopArrival nextStop) tzseries runningDay
-            - toSeconds (stopDeparture lastStop) tzseries runningDay
-
-        closestPoint = minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line
-        line = shapePoints tripShape
-        lastStop = tripStops V.! (nextIndex - 1)
-        nextStop = tripStops V.! nextIndex
-        -- | index of the /next/ stop in the list, except when we're already at the last stop
+          where p = seconds2Double (utcToSeconds trainPingTimestamp runningDay - lastSeconds)
+                  / seconds2Double expectedTravelTime
+
+        -- scheduled duration between last and next stops
+        expectedTravelTime = nextSeconds - lastSeconds
+
+        -- closest point on the shape; this is where we assume the train to be
+        closestPoint = minimumBy (compare `on` euclid trainPingGeopos) line
+
+        -- scheduled departure at last & arrival at next stop
+        lastSeconds = toSeconds (stopDeparture lastStop) lastTzSeries runningDay
+        nextSeconds = toSeconds (stopArrival nextStop) nextTzSeries runningDay
+
+        (lastStop, lastStation, lastTzSeries) = tripStops V.! (nextIndex - 1)
+        (nextStop, nextStation, nextTzSeries) = tripStops V.! nextIndex
+
+        line = fmap shapePointGeopos shape
+
+        -- index of the /next/ stop in the list, except when we're already at the last stop
         -- (in which case it stays the same)
         nextIndex = if
           | null remaining -> length tripStops - 1
@@ -110,23 +132,24 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, ob
           | otherwise      -> idx'
           where idx' = fst $ V.minimumBy (compare `on` snd) remaining
                 remaining = V.filter (\(_,dist) -> dist > 0) $ V.indexed
-                  $ fmap (distanceAlongLine line closestPoint . stationGeopos . stopStation) tripStops
+                  $ fmap (distanceAlongLine line closestPoint . stationGeopos . \(_,stop,_) -> stop) tripStops
 
-distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double
+-- | approximate (but euclidean) distance along a geoline
+distanceAlongLine :: V.Vector Geopos -> Geopos -> Geopos -> Double
 distanceAlongLine line p1 p2 = along2 - along1
   where along1 = along p1
         along2 = along p2
-        along p@(x,y) =
+        along p@(Geopos (x,y)) =
           sumSegments
           $ V.take (index + 1) line
           where index = V.minIndexBy (compare `on` euclid p) line
-        sumSegments :: V.Vector (Double, Double) -> Double
+        sumSegments :: V.Vector Geopos -> Double
         sumSegments line = snd
-          $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0) $ line
+          $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0) line
 
 -- | euclidean distance. Notably not applicable when you're on a sphere
 -- (but good enough when the sphere is the earth)
-euclid :: Floating f => (f,f) -> (f,f) -> f
-euclid (x1,y1) (x2,y2) = sqrt (x*x + y*y)
+euclid :: Geopos -> Geopos -> Double
+euclid (Geopos (x1,y1)) (Geopos (x2,y2)) = sqrt (x*x + y*y)
   where x = x1 - x2
         y = y1 - y2
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index c4652e8..cb9be2a 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -88,11 +88,11 @@ swaggerOptions prefix =
 -- whatsoever, but are given in the timezone of the transport agency, and
 -- potentially displayed in a different timezone depending on the station they
 -- apply to.
-data Time = Time { timeSeconds :: Int, timeTZseries :: TimeZoneSeries, timeTZname :: Text }
+data Time = Time { timeSeconds :: Int, tzname :: Text }
   deriving (Generic)
 
 instance ToJSON Time where
-  toJSON (Time seconds _ tzname) =
+  toJSON (Time seconds tzname) =
     A.object [ "seconds" A..= seconds, "timezone" A..= tzname ]
 
 -- | a type for all timetable values lacking context
@@ -115,7 +115,7 @@ seconds2Double = int2Double . unSeconds
 -- at the given number of seconds since midnight (note that this may lead to
 -- strange effects for timezone changes not taking place at midnight)
 toSeconds :: Time -> TimeZoneSeries -> Day -> Seconds
-toSeconds (Time seconds _ _) tzseries refday =
+toSeconds (Time seconds _) tzseries refday =
   Seconds $ seconds - timeZoneMinutes timezone * 60
   where timezone = timeZoneFromSeries tzseries reftime
         reftime = UTCTime refday (fromInteger $ toInteger seconds)
@@ -130,7 +130,7 @@ toUTC time tzseries refday =
 -- | Times in GTFS are given without timezone info, which is handled
 -- seperately (as an attribute of the stop / the agency). We attach that information
 -- back to the Time, this is just an intermediate step during parsing.
-newtype RawTime = RawTime { unRawTime :: TimeZoneSeries -> Text -> Time }
+newtype RawTime = RawTime { unRawTime :: Text -> Time }
   deriving (Generic)
 
 instance CSV.FromField RawTime where
@@ -143,7 +143,7 @@ instance CSV.FromField RawTime where
       _          -> fail $ "encountered an invalid date: " <> text
 
 instance Show Time where
-  show (Time seconds _ _) = ""
+  show (Time seconds _) = ""
     +|pad (seconds `div` 3600)|+":"
     +|pad ((seconds `mod` 3600) `div` 60)|+
     if seconds `mod` 60 /= 0 then":"+|pad (seconds `mod` 60)|+""
@@ -154,7 +154,7 @@ instance Show Time where
             where str = show num
 
 showTimeWithSeconds :: Time -> String
-showTimeWithSeconds (Time seconds _ _) = ""
+showTimeWithSeconds (Time seconds _) = ""
     +|pad (seconds `div` 3600)|+":"
     +|pad ((seconds `mod` 3600) `div` 60)|+
     ":"+|pad (seconds `mod` 60)|+""
@@ -587,8 +587,8 @@ loadGtfs path zoneinforoot = do
             tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname)
             pure (tzseries, tzname)
         pure $ stop { stopStation = station
-                    , stopDeparture = unRawTime (stopDeparture stop) tzseries tzname
-                    , stopArrival = unRawTime (stopArrival stop) tzseries tzname }
+                    , stopDeparture = unRawTime (stopDeparture stop) tzname
+                    , stopArrival = unRawTime (stopArrival stop) 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"
diff --git a/lib/Persist.hs b/lib/Persist.hs
index b52d7c6..7613fd9 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -16,10 +16,10 @@ import           Data.Swagger                (ToParamSchema (..), ToSchema (..),
 import           Data.Text                   (Text)
 import           Data.UUID                   (UUID)
 import           Database.Persist
-import           Database.Persist.Sql        (PersistFieldSql,
+import           Database.Persist.Sql        (PersistFieldSql (..),
                                               runSqlPersistMPool)
 import           Database.Persist.TH
-import           GTFS
+import qualified GTFS
 import           PersistOrphans
 import           Servant                     (FromHttpApiData (..),
                                               ToHttpApiData)
@@ -55,22 +55,65 @@ instance ToSchema Token where
 instance ToParamSchema Token where
   toParamSchema _ = toParamSchema (Proxy @String)
 
-deriving newtype instance PersistField Seconds
-deriving newtype instance PersistFieldSql Seconds
+deriving newtype instance PersistField GTFS.Seconds
+deriving newtype instance PersistFieldSql GTFS.Seconds
+
+instance PersistField GTFS.Time where
+  toPersistValue :: GTFS.Time -> PersistValue
+  toPersistValue (GTFS.Time seconds zone) = toPersistValue (seconds, zone)
+  fromPersistValue :: PersistValue -> Either Text GTFS.Time
+  fromPersistValue = fmap (uncurry GTFS.Time) . fromPersistValue
+
+instance PersistFieldSql GTFS.Time where
+  sqlType :: Proxy GTFS.Time -> SqlType
+  sqlType _ = sqlType (Proxy @(Int, Text))
+
+
+-- TODO: postgres actually has a native type for this
+newtype Geopos = Geopos { unGeoPos :: (Double, Double) }
+  deriving newtype (PersistField, PersistFieldSql, Show, Eq, FromJSON, ToJSON, ToSchema)
+
+latitude :: Geopos -> Double
+latitude = fst . unGeoPos
+
+longitude :: Geopos -> Double
+longitude = snd . unGeoPos
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 Ticket sql=tt_ticket
   Id UUID default=uuid_generate_v4()
-  trip TripId
+  tripName Text
   day Day
   imported UTCTime
   schedule_version ImportId Maybe
   vehicle Text Maybe
+  completed Bool
+  headsign Text
+  shape ShapeId
 
 Import sql=tt_imports
   url Text
   date UTCTime
 
+Stop sql=tt_stop
+  ticket TicketId
+  station StationId
+  arrival GTFS.Time
+  departure GTFS.Time
+  sequence Int
+
+Station sql=tt_station
+  geopos Geopos
+  shortName Text
+  name Text
+
+ShapePoint sql=tt_shape_point
+  geopos Geopos
+  index Int
+  shape ShapeId
+
+Shape sql=tt_shape
+
 -- | tokens which have been issued
 Tracker sql=tt_tracker_token
   Id Token default=uuid_generate_v4()
@@ -89,8 +132,7 @@ TrackerTicket
 TrainPing json sql=tt_trip_ping
   ticket TicketId
   token TrackerId
-  lat Double
-  long Double
+  geopos Geopos
   timestamp UTCTime
   deriving Show Generic Eq
 
@@ -99,9 +141,9 @@ TrainPing json sql=tt_trip_ping
 TrainAnchor json sql=tt_trip_anchor
   ticket TicketId
   created UTCTime
-  when Seconds
+  when GTFS.Seconds
   sequence Double
-  delay Seconds
+  delay GTFS.Seconds
   msg MultiLangText Maybe
   deriving Show Generic Eq
 
@@ -121,11 +163,11 @@ instance ToSchema TicketId where
 instance ToSchema TrackerId where
   declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
 instance ToSchema TrainPing where
-  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing")
+  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing")
 instance ToSchema TrainAnchor where
-  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainAnchor")
+  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor")
 instance ToSchema Announcement where
-  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "announcement")
+  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "announcement")
 
 runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
 runSql pool = liftIO . flip runSqlPersistMPool pool
diff --git a/lib/Server.hs b/lib/Server.hs
index c6d2d94..3922a7b 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -8,113 +8,128 @@
 
 -- Implementation of the API. This module is the main point of the program.
 module Server (application) where
-import           Control.Concurrent.STM      (TQueue, TVar, atomically,
-                                              newTQueue, newTVar, newTVarIO,
-                                              readTQueue, readTVar, writeTQueue,
-                                              writeTVar)
-import           Control.Monad               (forever, unless, void, when)
-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, NoLoggingT, logWarnN)
-import           Control.Monad.Reader        (ReaderT, forM)
-import           Control.Monad.Trans         (lift)
-import           Data.Aeson                  ((.=))
-import qualified Data.Aeson                  as A
-import qualified Data.ByteString.Char8       as C8
-import           Data.Coerce                 (coerce)
-import           Data.Functor                ((<&>))
-import qualified Data.Map                    as M
-import           Data.Pool                   (Pool)
-import           Data.Proxy                  (Proxy (Proxy))
-import           Data.Swagger                (toSchema)
-import           Data.Text                   (Text)
-import           Data.Text.Encoding          (decodeUtf8)
-import           Data.Time                   (NominalDiffTime,
-                                              UTCTime (utctDay), addUTCTime,
-                                              diffUTCTime, getCurrentTime,
-                                              nominalDay)
-import qualified Data.Vector                 as V
+import           Control.Concurrent.STM              (TQueue, TVar, atomically,
+                                                      newTQueue, newTVar,
+                                                      newTVarIO, readTQueue,
+                                                      readTVar, writeTQueue,
+                                                      writeTVar)
+import           Control.Monad                       (forever, unless, void,
+                                                      when)
+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, NoLoggingT,
+                                                      logWarnN)
+import           Control.Monad.Reader                (ReaderT, forM)
+import           Control.Monad.Trans                 (lift)
+import           Data.Aeson                          ((.=))
+import qualified Data.Aeson                          as A
+import qualified Data.ByteString.Char8               as C8
+import           Data.Coerce                         (coerce)
+import           Data.Functor                        ((<&>))
+import qualified Data.Map                            as M
+import           Data.Pool                           (Pool)
+import           Data.Proxy                          (Proxy (Proxy))
+import           Data.Swagger                        (toSchema)
+import           Data.Text                           (Text)
+import           Data.Text.Encoding                  (decodeUtf8)
+import           Data.Time                           (NominalDiffTime,
+                                                      UTCTime (utctDay),
+                                                      addUTCTime, diffUTCTime,
+                                                      getCurrentTime,
+                                                      nominalDay)
+import qualified Data.Vector                         as V
 import           Database.Persist
-import           Database.Persist.Postgresql (SqlBackend, runMigration)
-import           Fmt                         ((+|), (|+))
-import qualified Network.WebSockets          as WS
-import           Servant                     (Application,
-                                              ServerError (errBody), err401,
-                                              err404, serve,
-                                              serveDirectoryFileServer,
-                                              throwError)
-import           Servant.API                 (NoContent (..), (:<|>) (..))
-import           Servant.Server              (Handler, hoistServer)
-import           Servant.Swagger             (toSwagger)
+import           Database.Persist.Postgresql         (SqlBackend,
+                                                      migrateEnableExtension,
+                                                      runMigration)
+import           Fmt                                 ((+|), (|+))
+import qualified Network.WebSockets                  as WS
+import           Servant                             (Application,
+                                                      ServerError (errBody),
+                                                      err401, err404, serve,
+                                                      serveDirectoryFileServer,
+                                                      throwError)
+import           Servant.API                         (NoContent (..),
+                                                      (:<|>) (..))
+import           Servant.Server                      (Handler, hoistServer)
+import           Servant.Swagger                     (toSwagger)
 
 import           API
-import           GTFS
+import qualified GTFS
 import           Persist
 import           Server.ControlRoom
-import           Server.GTFS_RT              (gtfsRealtimeServer)
-import           Server.Util                 (Service, ServiceM, runService,
-                                              sendErrorMsg)
-import           Yesod                       (toWaiAppPlain)
+import           Server.GTFS_RT                      (gtfsRealtimeServer)
+import           Server.Util                         (Service, ServiceM,
+                                                      runService, sendErrorMsg)
+import           Yesod                               (toWaiAppPlain)
 
-import           Extrapolation               (Extrapolator (..),
-                                              LinearExtrapolator (..))
+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           Conduit                             (ResourceT)
+import           Config                              (ServerConfig (serverConfigAssets, serverConfigZoneinfoPath))
+import           Data.ByteString                     (ByteString)
+import           Data.ByteString.Lazy                (toStrict)
+import qualified Data.Text                           as T
+import           Data.Time.LocalTime.TimeZone.Olson  (getTimeZoneSeriesFromOlsonFile)
+import           Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
+import           Data.UUID                           (UUID)
 import           Prometheus
 import           Prometheus.Metric.GHC
+import           System.FilePath                     ((</>))
 
-application :: GTFS -> Pool SqlBackend -> ServerConfig -> IO Application
+application :: GTFS.GTFS -> Pool SqlBackend -> ServerConfig -> IO Application
 application gtfs dbpool settings = do
   doMigration dbpool
   metrics <- Metrics
     <$> register (gauge (Info "ws_connections" "Number of WS Connections"))
   register ghcMetrics
+
+  -- TODO: maybe cache these in a TVar, we're not likely to ever need
+  -- more than one of these
+  let getTzseries tzname = getTimeZoneSeriesFromOlsonFile
+        (serverConfigZoneinfoPath settings </> T.unpack tzname)
+
   subscribers <- newTVarIO mempty
-  pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool settings
+  pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService
+    $ server gtfs getTzseries metrics subscribers dbpool settings
 
 -- databaseMigration :: ConnectionString -> IO ()
-doMigration pool = runSql pool $
-  -- TODO: before that, check if the uuid module is enabled
-  -- in sql: check if SELECT * FROM pg_extension WHERE extname = 'uuid-ossp';
-  -- returns an empty list
-  runMigration migrateAll
-
-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
+doMigration pool = runSql pool $ runMigration $ do
+  migrateEnableExtension "uuid-ossp"
+  migrateAll
+
+server :: GTFS.GTFS -> (Text -> IO TimeZoneSeries) -> Metrics -> TVar (M.Map UUID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
+server gtfs getTzseries Metrics{..} subscribers dbpool settings = handleDebugAPI
+  :<|> (handleTimetable :<|> handleTimetableStops :<|> handleTrip
         :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
         :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain
-        :<|> handleDebugRegister :<|> pure gtfsFile :<|> gtfsRealtimeServer gtfs dbpool)
+        :<|> handleDebugRegister :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool)
   :<|> metrics
   :<|> serveDirectoryFileServer (serverConfigAssets settings)
   :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings)))
-  where handleStations = pure stations
-        handleTimetable station maybeDay =
-          M.filter isLastStop . tripsOnDay gtfs <$> liftIO day
-          where isLastStop = (==) station . stationId . stopStation . V.last . tripStops
+  where handleTimetable station maybeDay =
+          M.filter isLastStop . GTFS.tripsOnDay gtfs <$> liftIO day
+          where isLastStop = (==) station . GTFS.stationId . GTFS.stopStation . V.last . GTFS.tripStops
                 day = maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
         handleTimetableStops day =
-          pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day
-          where mkJson :: Trip Deep Deep -> A.Value
-                mkJson Trip {..} = A.object
+          pure . A.toJSON . fmap mkJson . M.elems $ GTFS.tripsOnDay gtfs day
+          where mkJson :: GTFS.Trip GTFS.Deep GTFS.Deep -> A.Value
+                mkJson GTFS.Trip {..} = A.object
                   [ "trip" .= tripTripId
-                  , "sequencelength" .= (stopSequence . V.last) tripStops
-                  , "stops" .= fmap (\Stop{..} -> A.object
-                    [ "departure" .= toUTC stopDeparture tzseries day
-                    , "arrival" .= toUTC stopArrival tzseries day
-                    , "station" .= stationId stopStation
-                    , "lat" .= stationLat stopStation
-                    , "lon" .= stationLon stopStation
+                  , "sequencelength" .= (GTFS.stopSequence . V.last) tripStops
+                  , "stops" .= fmap (\GTFS.Stop{..} -> A.object
+                    [ "departure" .= GTFS.toUTC stopDeparture (GTFS.tzseries gtfs) day
+                    , "arrival" .= GTFS.toUTC stopArrival (GTFS.tzseries gtfs) day
+                    , "station" .= GTFS.stationId stopStation
+                    , "lat" .= GTFS.stationLat stopStation
+                    , "lon" .= GTFS.stationLon stopStation
                     ]) tripStops
                   ]
-        handleTrip trip = case M.lookup trip trips of
+        handleTrip trip = case M.lookup trip (GTFS.trips gtfs) of
           Just res -> pure res
           Nothing  -> throwError err404
         handleRegister (ticketId :: UUID) RegisterJson{..} = do
@@ -130,26 +145,41 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
             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
+        handleTrainPing onError ping@TrainPing{..} =
+          let ticketId = trainPingTicket in
+          isTokenValid dbpool trainPingToken ticketId >>= \case
           Nothing -> do
             onError
             pure Nothing
           Just (tracker@Tracker{..}, ticket@Ticket{..}) -> do
-            let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs ticket ping
-            -- TODO: are these always inserted in order?
             runSql dbpool $ do
+
+              stations <- selectList [ StopTicket ==. ticketId ] [Asc StopArrival]
+                 >>= mapM (\stop -> do
+                   station <- getJust (stopStation (entityVal stop))
+                   tzseries <- liftIO $ getTzseries (GTFS.tzname (stopArrival (entityVal stop)))
+                   pure (entityVal stop, station, tzseries))
+                 <&> V.fromList
+
+              shapePoints <- selectList [ShapePointShape ==. ticketShape] [Asc ShapePointIndex]
+                <&> (V.fromList . fmap entityVal)
+
+              let anchor = extrapolateAnchorFromPing LinearExtrapolator
+                              ticket stations shapePoints ping
+
               insert ping
+
               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 (coerce trainPingTicket)
-              whenJust queues $
-                mapM_ (\q -> writeTQueue q (Just ping))
-              pure queues
-            pure (Just anchor)
+
+              queues <- liftIO $ atomically $ do
+                queues <- readTVar subscribers <&> M.lookup (coerce trainPingTicket)
+                whenJust queues $
+                  mapM_ (\q -> writeTQueue q (Just ping))
+                pure queues
+              pure (Just anchor)
         handleWS conn = do
           liftIO $ WS.forkPingThread conn 30
           incGauge metricsWSGauge
@@ -233,3 +263,4 @@ hasExpired limit = do
 
 validityPeriod :: NominalDiffTime
 validityPeriod = nominalDay
+
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 4fb5ba8..e89b184 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -17,12 +17,13 @@ import           Control.Monad.IO.Class    (MonadIO (liftIO))
 import qualified Data.Aeson                as A
 import qualified Data.ByteString.Char8     as C8
 import qualified Data.ByteString.Lazy      as LB
+import           Data.Function             (on, (&))
 import           Data.Functor              ((<&>))
-import           Data.List                 (lookup)
+import           Data.List                 (lookup, nubBy)
 import           Data.List.NonEmpty        (nonEmpty)
 import           Data.Map                  (Map)
 import qualified Data.Map                  as M
-import           Data.Maybe                (catMaybes, fromJust)
+import           Data.Maybe                (catMaybes, fromJust, isJust)
 import           Data.Pool                 (Pool)
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
@@ -42,7 +43,7 @@ import           Extrapolation             (Extrapolator (..),
 import           Fmt                       ((+|), (|+))
 import           GHC.Float                 (int2Double)
 import           GHC.Generics              (Generic)
-import           GTFS
+import qualified GTFS
 import           Numeric                   (showFFloat)
 import           Persist
 import           Server.Util               (Service, secondsNow)
@@ -60,7 +61,7 @@ import           Yesod.Orphans             ()
 
 
 data ControlRoom = ControlRoom
-  { getGtfs     :: GTFS
+  { getGtfs     :: GTFS.GTFS
   , getPool     :: Pool SqlBackend
   , getSettings :: ServerConfig
   }
@@ -70,17 +71,21 @@ mkMessage "ControlRoom" "messages" "en"
 mkYesod "ControlRoom" [parseRoutes|
 / RootR GET
 /auth AuthR Auth getAuth
-/trains TrainsR GET
-/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
+
+/tickets TicketsR GET
+/ticket/#UUID TicketViewR GET
+/ticket/map/#UUID TicketMapViewR GET
+/ticket/announce/#UUID AnnounceR POST
+/ticket/del-announce/#UUID DelAnnounceR GET
+
 /token/block/#Token TokenBlock GET
-/trips TripsViewR GET
-/trip/#TripId TripViewR GET
+
+/gtfs/trips GtfsTripsViewR GET
+/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
+/gtfs/import/#Day GtfsTicketImportR POST
+
 /obu OnboardUnitMenuR GET
-/obu/#TripId/#Day OnboardUnitR GET
+/obu/#UUID OnboardUnitR GET
 |]
 
 emptyMarkup :: MarkupM a -> Bool
@@ -90,10 +95,10 @@ emptyMarkup _         = False
 instance Yesod ControlRoom where
   authRoute _ = Just $ AuthR LoginR
   isAuthorized OnboardUnitMenuR _ = pure Authorized
-  isAuthorized (OnboardUnitR _ _) _ = pure Authorized
+  isAuthorized (OnboardUnitR _) _ = pure Authorized
   isAuthorized (AuthR _) _ = pure Authorized
   isAuthorized _ _ = do
-    UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin
+    UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
     if uffdConfigEnable then maybeAuthId >>= \case
       Just _  -> pure Authorized
       Nothing -> pure AuthenticationRequired
@@ -176,10 +181,10 @@ instance YesodAuth ControlRoom where
 
 
 getRootR :: Handler Html
-getRootR = redirect TrainsR
+getRootR = redirect TicketsR
 
-getTrainsR :: Handler Html
-getTrainsR = do
+getTicketsR :: Handler Html
+getTicketsR = do
   req <- getRequest
   let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
   mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
@@ -194,14 +199,13 @@ getTrainsR = do
   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))
+  tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do
+    stops <- selectList [ StopTicket ==. entityKey ticket ] []
+    startStation <- getJust (stopStation $ entityVal $ head stops)
+    pure (ticket, startStation, fmap entityVal stops))
+
+  let trips = GTFS.tripsOnDay gtfs day
+
   (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
   defaultLayout $ do
     [whamlet|
@@ -209,77 +213,130 @@ getTrainsR = do
 $maybe name <- mdisplayname
   <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
 <nav>
-  <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday}
+  <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday}
   $if isToday
     _{Msgtoday}
   $else
-    <a href="@{TrainsR}">_{Msgtoday}
-  <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
+    <a href="@{TicketsR}">_{Msgtoday}
+  <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
 <section>
   <h2>_{MsgTickets}
   <ol>
-   $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}
+   $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets
+    <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
+         : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
    $if null tickets
      <li style="text-align: center"><em>(_{MsgNone})
 <section>
   <h2>_{MsgAccordingToGtfs}
-  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+  <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
     ^{widget}
     <button>_{MsgImportTrips}
 |]
 
-postTicketImportR :: Day -> Handler Html
-postTicketImportR day = do
+
+-- TODO: this function should probably look for duplicate imports
+postGtfsTicketImportR :: Day -> Handler Html
+postGtfsTicketImportR day = do
   gtfs <- getYesod <&> getGtfs
-  let trips = tripsOnDay gtfs day
+  let trips = GTFS.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|
+
+      shapeMap <- selected
+        <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape))
+        & nubBy ((==) `on` fst)
+        & mapM (\(shapeId, shape) -> runDB $ do
+           key <- insert Shape
+           insertMany
+             $ shape
+             & GTFS.shapePoints
+             & V.indexed
+             & V.toList
+             <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key
+           pure (shapeId, key))
+        <&> M.fromList
+
+      stationMap <- selected
+        <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation))
+        & concat
+        & nubBy ((==) `on` GTFS.stationId)
+        & mapM (\GTFS.Station{..} -> runDB $ do
+            maybeExists <- selectFirst [ StationShortName ==. stationId ] []
+            case maybeExists of
+              Nothing -> do
+                key <- insert Station
+                  { stationGeopos = Geopos (stationLat, stationLon)
+                  , stationShortName = stationId , stationName }
+                pure (stationId, key)
+              Just (Entity key _) -> pure (stationId, key))
+        <&> M.fromList
+
+      selected
+        <&> (\(trip@GTFS.Trip{..}, day) ->
+            let
+              ticket = Ticket
+                   { ticketTripName = tripTripId, ticketDay = day, ticketImported = now
+                   , ticketSchedule_version = Nothing, ticketVehicle = Nothing
+                   , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip
+                   , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)}
+              stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop
+                   { stopTicket = ticketId
+                   , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap)
+                   , stopArrival, stopDeparture, stopSequence}
+            in (ticket, stops))
+        & unzip
+        & \(tickets, stops) -> runDB $ do
+            ticketIds <- insertMany tickets
+            forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) ->
+              insertMany (fmap (\s -> s ticketId) unfinishedStops)
+
+      redirect (TicketsR, [("day", T.pack (iso8601Show day))])
+
+    FormFailure _ -> defaultLayout [whamlet|
 <section>
   <h2>_{MsgAccordingToGtfs}
-  <form method=post action="@{TicketImportR day}" enctype=#{enctype}>
+  <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
     ^{widget}
     <button>_{MsgImportTrips}
 |]
 
 getTicketViewR :: UUID -> Handler Html
 getTicketViewR ticketId = do
-  Ticket{..} <- runDB $ get (TicketKey ticketId)
+  let ticketKey = TicketKey ticketId
+  Ticket{..} <- runDB $ get ticketKey
      >>= \case {Nothing -> notFound; Just a -> pure a}
 
-  GTFS{..} <- getYesod <&> getGtfs
+  stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
+    station <- getJust (stopStation (entityVal stop))
+    pure (entityVal stop, station))
+
+  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
+
   (widget, enctype) <- generateFormPost (announceForm ticketId)
-  case M.lookup ticketTrip trips of
-    Nothing -> notFound
-    Just res@Trip{..} -> do
-      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 ticketDay
-      defaultLayout $ do
-        mr <- getMessageRender
-        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 ticketDay))])}">#{ticketDay}</a>
+
+  nowSeconds <- secondsNow ticketDay
+  defaultLayout $ do
+    mr <- getMessageRender
+    setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
+    [whamlet|
+<h1>_{MsgTrip} #
+  <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName}
+  _{Msgon}
+  <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}
 <section>
   <h2>_{MsgLive}
   <p><strong>_{MsgLastPing}: </strong>
     $maybe Entity _ TrainPing{..} <- lastPing
-      _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
+      _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
       (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
     $nothing
       <em>(_{MsgNoTrainPing})
@@ -289,12 +346,12 @@ getTicketViewR ticketId = do
         \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
     $nothing
       <em> (_{MsgNone})
-  <p><a href="@{TrainMapViewR ticketId}">_{MsgMap}</a>
+  <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a>
 <section>
   <h2>_{MsgStops}
   <ol>
-    $forall Stop{..} <- tripStops
-      <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation}
+    $forall (Stop{..}, Station{..}) <- stops
+      <li value="#{stopSequence}"> #{stopArrival} #{stationName}
         $maybe history <- anchors
           $maybe delay <- guessDelay history (int2Double stopSequence)
             \ (#{delay})
@@ -329,16 +386,19 @@ getTicketViewR ticketId = do
                 guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
 
 
-getTrainMapViewR :: UUID -> Handler Html
-getTrainMapViewR ticketId = do
+getTicketMapViewR :: UUID -> Handler Html
+getTicketMapViewR ticketId = do
   Ticket{..} <- runDB $ get (TicketKey ticketId)
     >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
-  GTFS{..} <- getYesod <&> getGtfs
+
+  stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do
+    station <- getJust (stopStation (entityVal stop))
+    pure (entityVal stop, station))
+
   (widget, enctype) <- generateFormPost (announceForm ticketId)
-  case M.lookup ticketTrip trips of
-    Nothing -> notFound
-    Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{tripName res} _{Msgon} #{ticketDay}</a>
+
+  defaultLayout [whamlet|
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a>
 <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
      integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
      crossorigin=""/>
@@ -354,7 +414,7 @@ getTrainMapViewR ticketId = 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}/#{ticketDay}");
+  ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}");
 
   var marker = null;
 
@@ -373,27 +433,27 @@ getTrainMapViewR ticketId = do
 
 
 
-getTripsViewR :: Handler Html
-getTripsViewR = do
-  GTFS{..} <- getYesod <&> getGtfs
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
   defaultLayout $ do
     setTitle "List of Trips"
     [whamlet|
 <h1>List of Trips
 <section><ul>
-  $forall trip@Trip{..} <- trips
-    <li><a href="@{TripViewR tripTripId}">#{tripName trip}</a>
-      : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
+  $forall trip@GTFS.Trip{..} <- trips
+    <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
+      : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
 |]
 
 
-getTripViewR :: TripId -> Handler Html
-getTripViewR tripId = do
-  GTFS{..} <- getYesod <&> getGtfs
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
   case M.lookup tripId trips of
     Nothing -> notFound
-    Just trip@Trip{..} -> defaultLayout [whamlet|
-<h1>_{MsgTrip} #{tripName trip}
+    Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
 <section>
   <h2>_{MsgInfo}
   <p><strong>_{MsgtripId}:</strong> #{tripTripId}
@@ -402,8 +462,8 @@ getTripViewR tripId = do
 <section>
   <h2>_{MsgStops}
   <ol>
-    $forall Stop{..} <- tripStops
-      <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
+    $forall GTFS.Stop{..} <- tripStops
+      <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
 <section>
   <h2>Dates
   <ul>
@@ -454,21 +514,28 @@ getTokenBlock token = do
 getOnboardUnitMenuR :: Handler Html
 getOnboardUnitMenuR = do
   day <- liftIO getCurrentTime <&> utctDay
-  gtfs <- getYesod <&> getGtfs
-  let trips = tripsOnDay gtfs day
+
+  tickets <-
+    runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do
+      firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ]
+      pure (ticket, entityVal $ fromJust firstStop))
+
   defaultLayout $ do
     [whamlet|
 <h1>_{MsgOBU}
 <section>
   _{MsgChooseTrain}
-  $forall Trip{..} <- trips
+  $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
     <hr>
-    <a href="@{OnboardUnitR tripTripId day}">
-      #{tripTripId}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
+    <a href="@{OnboardUnitR ticketId}">
+      #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
 |]
 
-getOnboardUnitR :: TripId -> Day -> Handler Html
-getOnboardUnitR tripId day =
+getOnboardUnitR :: UUID -> Handler Html
+getOnboardUnitR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case
+    Nothing -> notFound
+    Just ticket -> pure ticket
   defaultLayout $(whamletFile "site/obu.hamlet")
 
 announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
@@ -481,7 +548,10 @@ announceForm ticketId = renderDivs $ Announcement
 
 
 
-tripImportForm :: [(Trip Deep Deep, Day)] -> Html -> MForm Handler (FormResult [(Trip Deep Deep, Day)], Widget)
+tripImportForm
+  :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
+  -> Html
+  -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
 tripImportForm trips extra = do
   forms <- forM trips $ \(trip, day) -> do
     (aRes, aView) <- mreq checkBoxField "import" Nothing
@@ -491,15 +561,15 @@ tripImportForm trips extra = do
   let widget = toWidget [whamlet|
      #{extra}
      <ol>
-       $forall (trip@Trip{..}, day, res, view) <- forms
+       $forall (trip@GTFS.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}
+             _{MsgTrip} #{GTFS.tripName trip}
+               : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
   |]
 
-  let (a :: FormResult [Maybe (Trip Deep Deep, Day)]) =
+  let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
         sequenceA (fmap (\(_,_,res,_) -> res) forms)
 
   pure (fmap catMaybes a, widget)
@@ -510,8 +580,8 @@ mightbe (Just a) = a
 mightbe Nothing  = ""
 
 
-headsign :: Trip 'Deep 'Deep -> Text
-headsign (Trip{..} :: Trip Deep Deep) =
+gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
+gtfsHeadsign GTFS.Trip{..} =
   case tripHeadsign of
     Just headsign -> headsign
-    Nothing       -> stationName (stopStation (V.last tripStops))
+    Nothing       -> GTFS.stationName (GTFS.stopStation (V.last tripStops))
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 412284f..48a84db 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -12,6 +12,7 @@ import           Control.Lens                ((&), (.~))
 import           Control.Monad               (forM)
 import           Control.Monad.Extra         (mapMaybeM)
 import           Control.Monad.IO.Class      (MonadIO (..))
+import           Data.Coerce                 (coerce)
 import           Data.Functor                ((<&>))
 import           Data.List.NonEmpty          (NonEmpty, nonEmpty)
 import qualified Data.Map                    as M
@@ -31,6 +32,7 @@ import qualified Data.UUID                   as UUID
 import qualified Data.Vector                 as V
 import           Database.Persist            (Entity (..),
                                               PersistQueryRead (selectFirst),
+                                              SelectOpt (Asc, Desc), get,
                                               getJust, selectKeysList,
                                               selectList, (<-.), (==.))
 import           Database.Persist.Postgresql (SqlBackend)
@@ -38,15 +40,16 @@ import           Extrapolation               (Extrapolator (extrapolateAtPositio
                                               LinearExtrapolator (..))
 import           GHC.Float                   (double2Float, int2Double)
 import           GTFS                        (Depth (..), GTFS (..),
-                                              Seconds (..), Stop (..),
-                                              Trip (..), TripId,
+                                              Seconds (..), Trip (..), TripId,
                                               showTimeWithSeconds, stationId,
                                               toSeconds, toUTC, tripsOnDay)
 import           Persist                     (Announcement (..),
                                               EntityField (..), Key (..),
+                                              Station (..), Stop (..),
                                               Ticket (..), Token (..),
                                               Tracker (..), TrainAnchor (..),
-                                              TrainPing (..), runSql)
+                                              TrainPing (..), latitude,
+                                              longitude, runSql)
 import qualified Proto.GtfsRealtime          as RT
 import qualified Proto.GtfsRealtime_Fields   as RT
 import           Servant.API                 ((:<|>) (..))
@@ -85,7 +88,7 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
               & RT.alert .~ (defMessage
                   & RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
                   & RT.informedEntity .~ [ defMessage
-                       & RT.trip .~ defTripDescriptor ticketTrip (Just ticketDay) Nothing
+                       & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) Nothing
                     ]
                   & RT.maybe'url .~ fmap (monolingual "de") announcementUrl
                   & RT.headerText .~ monolingual "de" announcementHeader
@@ -95,78 +98,84 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
     handleTripUpdates = runSql dbpool $ do
       today <- liftIO $ getCurrentTime <&> utctDay
       nowSeconds <- secondsNow today
-      let running = M.toList (tripsOnDay gtfs today)
-      anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
-        tickets <- selectKeysList [TicketTrip ==. tripId, TicketDay ==. today] []
-        entities <- selectList [TrainAnchorTicket <-. tickets] []
-        case nonEmpty (fmap entityVal entities) of
+      -- let running = M.toList (tripsOnDay gtfs today)
+      tickets <- selectList [TicketCompleted ==. False] [Asc TicketTripName]
+
+      tripUpdates <- forM tickets $ \(Entity key Ticket{..}) -> do
+        selectList [TrainAnchorTicket ==. key] [] >>= \a -> case nonEmpty a of
           Nothing      -> pure Nothing
-          Just anchors -> pure $ Just (tripId, trip, anchors)
+          Just anchors -> do
+            stops <- selectList [StopTicket ==. key] [Asc StopArrival] >>= mapM (\(Entity _ stop) -> do
+              station <- getJust (stopStation stop)
+              pure (stop, station))
 
-      defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors)
-      where
-        mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity
-        mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) =
-              let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds
-                  stations = tripStops
-                    <&> (\stop@Stop{..} -> (, stop)
-                          <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence))
-                  (lastAnchor, lastStop) = V.last (V.catMaybes stations)
-                  stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
+            let anchorEntities = fmap entityVal anchors
+            let lastCall = extrapolateAtSeconds LinearExtrapolator anchorEntities nowSeconds
+            let atStations = flip fmap stops $ \(stop, station) ->
+                  (, stop, station) <$> extrapolateAtPosition LinearExtrapolator anchorEntities (int2Double (stopSequence stop))
+            let (lastAnchor, lastStop, lastStation) = last (catMaybes atStations)
+            let stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
                     < nowSeconds + 5 * 60
-              in if not stillRunning then Nothing else Just $ defMessage
-                & RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today))
-                & RT.tripUpdate .~ (defMessage
-                    & RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops))
-                    & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations)
-                    & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
-                    & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
-                )
-          where
-            mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate
-            mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage
-              & RT.stopSequence .~ fromIntegral stopSequence
-              & RT.stopId .~ stationId stopStation
-              & RT.arrival .~ (defMessage
+
+            pure $ Just $ defMessage
+              & RT.id .~ UUID.toText (coerce key)
+              & RT.tripUpdate .~ (defMessage
+                 & RT.trip .~
+                   defTripDescriptor
+                     ticketTripName (Just today)
+                     (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ fst $ head stops))
+                 & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes atStations)
+                 & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
+                 & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
+              )
+            where
+              mkStopTimeUpdate :: (TrainAnchor, Stop, Station) -> RT.TripUpdate'StopTimeUpdate
+              mkStopTimeUpdate (TrainAnchor{..}, Stop{..}, Station{..}) = defMessage
+                & RT.stopSequence .~ fromIntegral stopSequence
+                & RT.stopId .~ stationShortName
+                & RT.arrival .~ (defMessage
                   & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
                   & RT.time .~ toStupidTime (addUTCTime
                       (fromIntegral $ unSeconds trainAnchorDelay)
                       (toUTC stopArrival tzseries today))
                   & RT.uncertainty .~ 60
-              )
-              & RT.departure .~ (defMessage
-                  & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
-                  & RT.time .~ toStupidTime (addUTCTime
+                )
+                & RT.departure .~ (defMessage
+                    & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
+                    & RT.time .~ toStupidTime (addUTCTime
                       (fromIntegral $ unSeconds trainAnchorDelay)
                       (toUTC stopDeparture tzseries today))
-                  & RT.uncertainty .~ 60
-              )
-              & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+                    & RT.uncertainty .~ 60
+                )
+                & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+
+      defFeedMessage (catMaybes tripUpdates)
 
     handleVehiclePositions = runSql dbpool $ do
-      (trackers :: [Entity Tracker]) <- selectList [] []
-      pings <- forM trackers $ \(Entity trackerId tracker) -> do
-        selectFirst [TrainPingToken ==. trackerId] [] >>= \case
+
+      ticket <- selectList [TicketCompleted ==. False] []
+
+      positions <- forM ticket $ \(Entity key ticket) -> do
+        selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case
           Nothing -> pure Nothing
-          Just ping -> do
-            ticket <- getJust (trainPingTicket (entityVal ping))
-            pure (Just (ping, ticket, tracker))
+          Just lastPing ->
+            pure (Just $ mkPosition (lastPing, ticket))
 
-      defFeedMessage (mkPosition <$> catMaybes pings)
+      defFeedMessage (catMaybes positions)
 
       where
-        mkPosition :: (Entity TrainPing, Ticket, Tracker) -> RT.FeedEntity
-        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Ticket{..}, Tracker{..}) = defMessage
+        mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity
+        mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage
           & RT.id .~ T.pack (show key)
           & RT.vehicle .~ (defMessage
-              & RT.trip .~ defTripDescriptor ticketTrip Nothing Nothing
+              & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing
               & RT.maybe'vehicle .~ case ticketVehicle of
                   Nothing -> Nothing
                   Just trainset -> Just $ defMessage
                     & RT.label .~ trainset
               & RT.position .~ (defMessage
-                  & RT.latitude .~ double2Float trainPingLat
-                  & RT.longitude .~ double2Float trainPingLong
+                  & RT.latitude .~ double2Float (latitude trainPingGeopos)
+                  & RT.longitude .~ double2Float (longitude trainPingGeopos)
               )
               -- TODO: should probably give currentStopSequence/stopId here as well
               & RT.timestamp .~ toStupidTime trainPingTimestamp
diff --git a/messages/de.msg b/messages/de.msg
index f3a9e2b..53e5ede 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -39,7 +39,7 @@ Submit: Ok
 ImportTrips: Fahrten importieren
 Tickets: Tickets
 delete: löschen
-AccordingToGtfs: Fahrten im GTFS
+AccordingToGtfs: Weitere Fahrten im GTFS
 
 OBU: Onboard-Unit
 ChooseTrain: Fahrt auswählen
diff --git a/messages/en.msg b/messages/en.msg
index 2c734d2..41ced10 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -39,7 +39,7 @@ Submit: Submit
 Tickets: Tickets
 ImportTrips: import selected trips
 delete: delete
-AccordingToGtfs: Trips contained in the Gtfs
+AccordingToGtfs: Additional Trips contained in the Gtfs
 
 OBU: Onboard-Unit
 ChooseTrain: Choose a Train
diff --git a/site/obu.hamlet b/site/obu.hamlet
index 7068014..ed8017a 100644
--- a/site/obu.hamlet
+++ b/site/obu.hamlet
@@ -1,7 +1,7 @@
 <h1>_{MsgOBU}
 
 <section>
-  <h2>#{tripId} _{Msgon} #{day}
+  <h2>#{ticketTripName} _{Msgon} #{ticketDay}
   <strong>Token:</strong> <span id="token">
 
 <section>
@@ -107,10 +107,10 @@
 
 
   async function main() {
-    let trip = await (await fetch("/api/trip/#{tripId}")).json();
+    let trip = await (await fetch("/api/trip/#{ticketTripName}")).json();
     console.log("got trip info");
 
-    token = await (await fetch("/api/train/register/#{tripId}", {
+    token = await (await fetch("/api/train/register/#{UUID.toText ticketId}", {
       method: "POST",
       body: JSON.stringify({agent: "onboard-unit"}),
       headers: {"Content-Type": "application/json"}
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 1179bdd..ad1624f 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -96,6 +96,7 @@ library
                     , exceptions
                     , proto-lens
                     , http-media
+                    , filepath
     hs-source-dirs:   lib
     exposed-modules: GTFS
                    , Server