this does way too much tbh (also functioning delays)

most of it deals with timezones, and all the weird implications that has

6 files changed, 346 insertions, 99 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 9016524..35bdee7 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -33,7 +33,6 @@ import           GTFS
 import           GTFS.Realtime.FeedEntity
 import           GTFS.Realtime.FeedMessage   (FeedMessage)
 import           Persist
-import           Server.ControlRoom
 
 data RegisterJson = RegisterJson
   { registerAgent :: Text }
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
new file mode 100644
index 0000000..9b3f89f
--- /dev/null
+++ b/lib/Extrapolation.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE AllowAmbiguousTypes     #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE ConstraintKinds         #-}
+{-# LANGUAGE DataKinds               #-}
+{-# LANGUAGE RecordWildCards         #-}
+
+module Extrapolation (Extrapolator(..), LinearExtrapolator, linearDelay) where
+import           Data.Foldable (maximumBy, minimumBy)
+import           Data.Function (on)
+import qualified Data.Map      as M
+import           Data.Time     (Day, UTCTime (UTCTime), diffUTCTime,
+                                nominalDiffTimeToSeconds)
+import qualified Data.Vector   as V
+import           Persist       (Running (..), TrainAnchor (..), TrainPing (..))
+
+import           GHC.Float     (int2Double)
+import           GHC.IO        (unsafePerformIO)
+import           GTFS          (Depth (Deep), GTFS (..), Shape (..), Stop (..),
+                                Time, Trip (..), stationGeopos, toSeconds)
+
+
+
+class Extrapolator a where
+  guessStatusAt :: [TrainAnchor] -> UTCTime -> TrainAnchor
+  guessAnchor :: GTFS -> Running -> TrainPing -> TrainAnchor
+
+data LinearExtrapolator
+
+instance Extrapolator LinearExtrapolator where
+  guessStatusAt history when =
+    minimumBy (compare `on` difference)
+    $ filter (\a -> trainAnchorWhen a > when) history
+    where difference status = diffUTCTime when (trainAnchorWhen status)
+
+  guessAnchor gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor
+    { trainAnchorCreated = trainPingTimestamp
+    , trainAnchorTrip = runningTrip
+    , trainAnchorDay = runningDay
+    , trainAnchorWhen = trainPingTimestamp
+    , trainAnchorDelay = Just (linearDelay gtfs trip ping runningDay)
+    , trainAnchorMsg = Nothing
+    }
+    where Just trip = M.lookup runningTrip trips
+
+linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> Int
+linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ do
+  print (nextStop, lastStop)
+  print expectedTravelTime
+  -- print (((utcToSeconds trainPingTimestamp runningDay),  toSeconds (stopDeparture lastStop)))
+  print (observedProgress, expectedProgress)
+  pure $ round $ (expectedProgress - observedProgress) * int2Double expectedTravelTime
+  where closestPoint =
+            minimumBy (compare `on` (euclid (trainPingLat, trainPingLong))) line
+        nextStop = snd $
+            minimumBy (compare `on` fst)
+            $ V.filter (\(dist,_) -> dist > 0)
+            $ fmap (\stop -> (distanceAlongLine line closestPoint (stationGeopos $ stopStation stop), stop)) tripStops
+        lastStop = snd $
+            maximumBy (compare `on` fst)
+            $ V.filter (\(dist,_) -> dist < 0)
+            $ fmap (\stop -> (distanceAlongLine line closestPoint (stationGeopos $ stopStation stop), stop)) tripStops
+        line = shapePoints tripShape
+        expectedTravelTime =
+            toSeconds (stopArrival nextStop) tzseries trainPingTimestamp
+            - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp
+        expectedProgress =
+            (int2Double ((utcToSeconds trainPingTimestamp runningDay)
+                         - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp))
+            / int2Double expectedTravelTime
+            -- where crop a
+            --         | a < 0 = 0
+            --         | a > 1 = 1
+            --         | otherwise = a
+        observedProgress =
+            distanceAlongLine line (stationGeopos $ stopStation lastStop) closestPoint
+            / distanceAlongLine line (stationGeopos $ stopStation lastStop) (stationGeopos $ stopStation nextStop)
+
+distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double
+distanceAlongLine line p1 p2 = along2 - along1
+  where along1 = along p1
+        along2 = along p2
+        along p@(x,y) = snd
+          $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0)
+          $ V.take (index + 1) line
+          where index = fst $ minimumBy (compare `on` (euclid p . snd))
+                  $ V.indexed line
+
+-- | convert utc time to seconds on a day, with wrap-around
+-- for trains that cross midnight.
+utcToSeconds :: UTCTime -> Day -> Int
+utcToSeconds time day =
+  round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0)
+
+euclid :: Fractional f => (f,f) -> (f,f) -> f
+euclid (x1,y1) (x2,y2) = x*x + y*y
+  where x = x1 - x2
+        y = y1 - y2
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index bfb1c49..2047d56 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -19,51 +19,63 @@
 -- (i.e. parsing, querying, Aeson instances, etc.)
 module GTFS where
 
-import qualified Codec.Archive.Zip              as Zip
-import           Control.Monad.ST               (runST)
-import           Data.Aeson                     (FromJSON,
-                                                 Options (fieldLabelModifier),
-                                                 ToJSON, defaultOptions,
-                                                 genericParseJSON,
-                                                 genericToJSON)
-import qualified Data.Aeson                     as A
-import qualified Data.ByteString                as BS
-import qualified Data.ByteString.Lazy           as LB
-import           Data.Csv                       ((.:))
-import qualified Data.Csv                       as CSV
-import           Data.Function                  (on)
-import           Data.Functor                   ((<&>))
-import           Data.Kind                      (Type)
-import           Data.Maybe                     (fromJust, fromMaybe)
-import           Data.Text                      (Text)
-import           Data.Time                      (UTCTime (utctDay), dayOfWeek,
-                                                 getCurrentTime)
-import           Data.Time.Calendar             (Day, DayOfWeek (..))
-import           Data.Time.Calendar.MonthDay    (monthAndDayToDayOfYearValid)
-import qualified Data.Time.Calendar.OrdinalDate as Day
-import           Data.Vector                    (Vector)
-import qualified Data.Vector                    as V
-import qualified Data.Vector.Algorithms.Intro   as V
-import           Fmt                            ((+|), (|+))
-import           GHC.Generics                   (Generic)
-import           Text.Regex.TDFA                ((=~))
-import           Web.Internal.FormUrlEncoded    (FromForm (..))
-import           Web.Internal.HttpApiData       (FromHttpApiData (..))
+import qualified Codec.Archive.Zip                   as Zip
+import           Control.Monad.ST                    (runST)
+import           Data.Aeson                          (FromJSON,
+                                                      Options (fieldLabelModifier),
+                                                      ToJSON, defaultOptions,
+                                                      genericParseJSON,
+                                                      genericToJSON)
+import qualified Data.Aeson                          as A
+import qualified Data.ByteString                     as BS
+import qualified Data.ByteString.Lazy                as LB
+import           Data.Csv                            ((.:))
+import qualified Data.Csv                            as CSV
+import           Data.Function                       (on)
+import           Data.Functor                        ((<&>))
+import           Data.Kind                           (Type)
+import           Data.Maybe                          (fromJust, fromMaybe)
+import           Data.Text                           (Text)
+import           Data.Time                           (TimeZone (timeZoneMinutes),
+                                                      UTCTime (utctDay),
+                                                      dayOfWeek, getCurrentTime)
+import           Data.Time.Calendar                  (Day, DayOfWeek (..))
+import           Data.Time.Calendar.MonthDay         (monthAndDayToDayOfYearValid)
+import qualified Data.Time.Calendar.OrdinalDate      as Day
+import           Data.Vector                         (Vector)
+import qualified Data.Vector                         as V
+import qualified Data.Vector.Algorithms.Intro        as V
+import           Fmt                                 ((+|), (|+))
+import           GHC.Generics                        (Generic)
+import           Text.Regex.TDFA                     ((=~))
+import           Web.Internal.FormUrlEncoded         (FromForm (..))
+import           Web.Internal.HttpApiData            (FromHttpApiData (..))
 -- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
+import           Control.Applicative                 ((<|>))
 import           Control.Lens
-import           Control.Monad.IO.Class         (MonadIO (liftIO))
-import           Data.Char                      (toLower)
-import           Data.Foldable                  (Foldable (fold))
-import           Data.Map                       (Map)
-import qualified Data.Map                       as M
-import           Data.Proxy                     (Proxy (Proxy))
-import           Data.Swagger                   (ParamSchema (..),
-                                                 SchemaOptions,
-                                                 ToSchema (declareNamedSchema),
-                                                 defaultSchemaOptions,
-                                                 genericDeclareNamedSchema)
-import qualified Data.Swagger                   as S
-import qualified Data.Text                      as T
+import           Control.Monad                       (when)
+import           Control.Monad.IO.Class              (MonadIO (liftIO))
+import           Data.ByteString                     (ByteString)
+import           Data.Char                           (toLower)
+import           Data.Foldable                       (Foldable (fold))
+import           Data.Map                            (Map)
+import qualified Data.Map                            as M
+import           Data.Proxy                          (Proxy (Proxy))
+import           Data.Swagger                        (ParamSchema (..),
+                                                      SchemaOptions,
+                                                      ToSchema (declareNamedSchema),
+                                                      defaultSchemaOptions,
+                                                      genericDeclareNamedSchema)
+import qualified Data.Swagger                        as S
+import qualified Data.Text                           as T
+import           Data.Time.LocalTime.TimeZone.Olson  (getTimeZoneSeriesFromOlsonFile)
+import           Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries,
+                                                      timeZoneFromSeries)
+
+
+-- | for some reason this doesn't exist already in cassava
+(.:?) :: forall a. (CSV.FromField (Maybe a)) => CSV.NamedRecord -> ByteString -> CSV.Parser (Maybe a)
+(.:?) r field = r .: field <|> pure Nothing
 
 aesonOptions prefix =
   defaultOptions { fieldLabelModifier = fieldModifier (T.length prefix) }
@@ -78,29 +90,54 @@ swaggerOptions prefix =
          c:rest -> toLower c : rest
          ""     -> ""
 
-newtype Time = Time { toSeconds :: Int }
-  deriving newtype (ToJSON, FromJSON)
+-- | Times in GTFS are a weird beast, lacking any kinda of timezone information
+-- 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 }
   deriving (Generic)
 
-instance CSV.FromField Time where
+instance ToJSON Time where
+  toJSON (Time seconds _ tzname) =
+    A.object [ "seconds" A..= seconds, "timezone" A..= tzname ]
+
+-- | converts a value of Time to seconds since midnight in UTC. Itself needs
+-- a UTCTime to resolve timezone changes, and the timezone info contained in
+-- the GTFS agency
+toSeconds :: Time -> TimeZoneSeries -> UTCTime -> Int
+toSeconds (Time seconds _ _) tzseries reftime =
+  seconds - timeZoneMinutes timezone * 60
+  where timezone = timeZoneFromSeries tzseries reftime
+
+-- | 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 }
+  deriving (Generic)
+
+instance CSV.FromField RawTime where
   parseField f = do
     text :: String <- CSV.parseField f
     let (_,_,_,subs) = text =~ ("([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?)" :: Text)
           :: (String, String, String, [String])
     case subs of
-      [hh,mm,ss] -> pure $ Time $ read hh * 3600 + read mm * 60 + read ss
+      [hh,mm,ss] -> pure $ RawTime $ Time (read hh * 3600 + read mm * 60 + read ss)
       _          -> 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)|+""
     else ""
-    where pad num =
+    where
+      pad num =
             if length str < 2 then "0"<>str else str
             where str = show num
 
+instance Show RawTime where
+  show raw = "[raw time value]" -- show (unRawTime raw 0)
+
 instance CSV.FromField Day where
   parseField f = do
     text :: String <- CSV.parseField f
@@ -134,10 +171,11 @@ type ServiceID = Text
 
 -- | This is what's called a Stop in GTFS
 data Station = Station
-  { stationId   :: StationID
-  , stationName :: Text
-  , stationLat  :: Float
-  , stationLon  :: Float
+  { stationId       :: StationID
+  , stationName     :: Text
+  , stationLat      :: Double
+  , stationLon      :: Double
+  , stationTimezone :: Maybe Text
   } deriving (Show, Generic)
 
 instance ToSchema Station where
@@ -147,21 +185,25 @@ instance FromJSON Station where
 instance ToJSON Station where
   toJSON = genericToJSON (aesonOptions "station")
 
+stationGeopos :: Station -> (Double, Double)
+stationGeopos Station{..} = (stationLat, stationLon)
 
 -- | This is what's called a stop time in GTFS
 data Stop (deep :: Depth) = Stop
   { stopTrip      :: TripID
-  , stopArrival   :: Time
-  , stopDeparture :: Time
+  , stopArrival   :: Switch deep Time RawTime
+  , stopDeparture :: Switch deep Time RawTime
   , stopStation   :: Switch deep Station StationID
   , stopSequence  :: Int
   } deriving Generic
 
-deriving instance Show (Stop 'Shallow)
+-- deriving instance Show (Stop 'Shallow)
 deriving instance Show (Stop 'Deep)
-instance FromJSON (Switch a Station StationID) => FromJSON (Stop a) where
-  parseJSON = genericParseJSON (aesonOptions "stop")
-instance ToJSON (Switch a Station StationID) => ToJSON (Stop a) where
+-- instance FromJSON (Switch a Station StationID) => FromJSON (Stop a) where
+--   parseJSON = genericParseJSON (aesonOptions "stop")
+instance (ToJSON (Switch a Station StationID)
+         , ToJSON (Switch a Time RawTime))
+       => ToJSON (Stop a) where
   toJSON = genericToJSON (aesonOptions "stop")
 instance ToSchema (Stop Deep)where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "stop")
@@ -203,7 +245,7 @@ instance ToJSON CalendarDate where
 instance FromForm CalendarDate
 
 data Trip (deep :: Depth) (shape :: Depth)= Trip
-  { tripRoute     :: Text
+  { tripRoute     :: Switch deep (Route Deep) Text
   , tripTripID    :: TripID
   , tripHeadsign  :: Maybe Text
   , tripShortName :: Maybe Text
@@ -222,9 +264,9 @@ tripForgetShape trip = trip { tripShape = shapeId (tripShape trip) }
 deriving instance Show (Trip Shallow Shallow)
 deriving instance Show (Trip Deep Deep)
 deriving instance Show (Trip Deep Shallow)
-instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d))), FromJSON (Switch s Shape Text)) => FromJSON (Trip d s) where
-  parseJSON = genericParseJSON (aesonOptions "trip")
-instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d))), ToJSON (Switch s Shape Text)) => ToJSON (Trip d s) where
+-- instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d))), FromJSON (Switch s Shape Text), FromJSON (Switch d (Route 'Deep) Text)) => FromJSON (Trip d s) where
+--   parseJSON = genericParseJSON (aesonOptions "trip")
+instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d))), ToJSON (Switch s Shape Text), ToJSON (Switch d (Route 'Deep) Text)) => ToJSON (Trip d s) where
   toJSON = genericToJSON (aesonOptions "trip")
 instance ToSchema (Trip Deep Deep) where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")
@@ -254,12 +296,54 @@ instance ToJSON Shape where
 instance ToSchema Shape where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "shape")
 
+data Agency depth = Agency
+  { agencyId       :: Maybe Text
+  , agencyName     :: Text
+  , agencyUrl      ::  Text
+  , agencyTimezone :: Switch depth TimeZoneSeries Text
+  , agencyLang     :: Maybe Text
+  , agencyPhone    :: Maybe Text
+  , agencyFareUrl  :: Maybe Text
+  , agencyEmail    :: Maybe Text
+  } deriving (Generic)
+
+deriving instance Show (Switch depth TimeZoneSeries Text) => Show (Agency depth)
+instance ToJSON (Agency Deep) where
+  toJSON = genericToJSON (aesonOptions "agency")
+instance ToSchema (Agency Deep) where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "agency")
+instance ToJSON TimeZoneSeries where
+  toJSON tz = "[timezoneseries thingie]"
+instance ToSchema TimeZoneSeries where
+  declareNamedSchema _ = declareNamedSchema (Proxy @String)
+
+data Route depth = Route
+  { routeId          :: Text
+  , routeAgency      :: Switch depth (Agency Deep) (Maybe Text)
+  , routeShortName   :: Maybe Text
+  , routeLongName    :: Maybe Text
+  , routeDescription :: Maybe Text
+  , routeType        :: Int
+  , routeUrl         :: Maybe Text
+  , routeColor       :: Maybe Text
+  , routeTextColor   :: Maybe Text
+  , routeSortOrder   :: Maybe Int
+  , routeNetworkId   :: Maybe Text
+  } deriving (Generic)
+
+deriving instance Show (Switch depth (Agency Deep) (Maybe Text)) => Show (Route depth)
+instance ToJSON (Route Deep) where
+  toJSON = genericToJSON (aesonOptions "route")
+instance ToSchema (Route Deep) where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "route")
+
 instance CSV.FromNamedRecord Station where
   parseNamedRecord r = Station
     <$> r .: "stop_id"
     <*> r .: "stop_name"
     <*> r .: "stop_lat"
     <*> r .: "stop_lon"
+    <*> r .:? "stop_timezone"
 
 instance CSV.FromNamedRecord (Stop 'Shallow) where
   parseNamedRecord r = Stop
@@ -329,6 +413,33 @@ instance CSV.FromNamedRecord (Trip Shallow Shallow) where
     <*> r .: "shape_id"
     <*> pure ()
 
+instance CSV.FromNamedRecord (Agency Shallow) where
+  parseNamedRecord r = Agency
+    <$> r .:? "agency_id"
+    <*> r .: "agency_name"
+    <*> r .: "agency_url"
+    <*> r .: "agency_timezone"
+    <*> r .:? "agency_lang"
+    <*> r .:? "agency_phone"
+    <*> r .:? "agency_fare_url"
+    <*> r .:? "agency_email"
+
+instance CSV.FromNamedRecord (Route Shallow) where
+  parseNamedRecord r = Route
+    <$> r .: "route_id"
+    <*> r .:? "agency_id"
+    <*> r .:? "route_short_name"
+    <*> r .:? "route_long_name"
+    <*> r .:? "route_desc"
+    <*> r .: "route_type"
+    <*> r .:? "route_url"
+    <*> r .:? "route_color"
+    <*> r .:? "route_text_color"
+    <*> r .:? "route_sort_order"
+    <*> r .:? "network_id"
+
+
+
 data RawGTFS = RawGTFS
   { rawStations      :: Vector Station
   , rawStops         :: Vector (Stop Shallow)
@@ -336,6 +447,8 @@ data RawGTFS = RawGTFS
   , rawCalendar      :: Maybe (Vector Calendar)
   , rawCalendarDates :: Maybe (Vector CalendarDate)
   , rawShapePoints   :: Maybe (Vector ShapePoint)
+  , rawAgencies      :: Vector (Agency Shallow)
+  , rawRoutes        :: Vector (Route Shallow)
   }
 
 
@@ -345,11 +458,11 @@ data GTFS = GTFS
   , calendar      :: Map DayOfWeek (Vector Calendar)
   , calendarDates :: Map Day (Vector CalendarDate)
   , shapes        :: Map Text Shape
-
-  , fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep Deep))
-  -- ^ a more "fancy" encoding of the calendar?
-  } -- deriving Show
-
+  , agencies      :: Vector (Agency Deep)
+  -- ^ not a Map AgencyID Agency since if there's only one agency, it may lack an ID
+  , routes        :: Map Text (Route Deep)
+  , tzseries      :: TimeZoneSeries
+  }
 
 
 loadRawGtfs :: FilePath -> IO RawGTFS
@@ -362,6 +475,8 @@ loadRawGtfs path = do
       <*> decodeTable "calendar.txt" zip
       <*> decodeTable "calendar_dates.txt" zip
       <*> decodeTable "shapes.txt" zip
+      <*> decodeTable' "agency.txt" zip
+      <*> decodeTable' "routes.txt" zip
     where
       decodeTable :: CSV.FromNamedRecord a => FilePath -> Zip.Archive -> IO (Maybe (Vector a))
       decodeTable path zip =
@@ -383,15 +498,17 @@ loadGtfs path = do
           V.foldr' sortShapePoint mempty
           $ V.modify (V.sortBy (compare `on` shapePtSequence))
           (fromMaybe mempty rawShapePoints)
-    stops' <- V.mapM (pushStop rawStations) rawStops
-    trips' <- V.mapM (pushTrip stops' shapes) rawTrips
+    -- all agencies must have the same timezone, so just take the first's
+    let tzname = agencyTimezone $ V.head rawAgencies
+    tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname)
+    let agencies' = fmap (\a -> a { agencyTimezone = tzseries }) rawAgencies
+    routes' <- V.mapM (\raw -> pushRoute agencies' raw) rawRoutes
+      <&> mapFromVector routeId
+    stops' <- V.mapM (pushStop tzseries tzname rawStations) rawStops
+    trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips
     pure $ GTFS
-      { stations =
-        M.fromList $ (\station -> (stationId station, station))
-        <$> V.toList rawStations
-      , trips =
-        M.fromList $ (\trip -> (tripTripID trip, trip))
-        <$> V.toList trips'
+      { stations = mapFromVector stationId rawStations
+      , trips = mapFromVector tripTripID trips'
       , calendar =
         fmap V.fromList
         $ M.fromListWith (<>)
@@ -402,8 +519,13 @@ loadGtfs path = do
         $ M.fromListWith (<>) $ (\cd -> (caldateDate cd, [cd]))
         <$> V.toList (fromMaybe mempty rawCalendarDates)
       , shapes
+      , agencies = agencies'
+      , routes = routes'
+      , tzseries
       }
     where
+      mapFromVector :: Ord k => (a -> k) -> Vector a  -> Map k a
+      mapFromVector by v = M.fromList $ fmap (\a -> (by a,a)) $ V.toList v
       weekdays Calendar{..} =
         [Monday | calMonday]
         <> [Tuesday | calTuesday]
@@ -412,23 +534,44 @@ loadGtfs path = do
         <> [Friday | calFriday]
         <> [Saturday | calSaturday]
         <> [Sunday | calSunday]
-      pushStop :: Vector Station -> Stop Shallow -> IO (Stop Deep)
-      pushStop stations stop = do
+      pushStop :: TimeZoneSeries -> Text -> Vector Station -> Stop Shallow -> IO (Stop Deep)
+      pushStop tzseries tzname stations stop = do
         station <- case tableLookup stationId (stopStation stop) stations of
           Just a -> pure a
-          Nothing -> fail $ "station with id "+|stopStation stop|+"is mentioned but not defined."
-        pure $ stop { stopStation = station }
-      pushTrip :: Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep)
-      pushTrip stops shapes trip = if V.length alongRoute < 2
+          Nothing -> fail $ "station with id "+|stopStation stop|+" is mentioned but not defined."
+        (tzseries', tzname') <- case stationTimezone station of
+          Nothing -> pure (tzseries, tzname)
+          Just tzname -> 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 }
+      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"
           else do
-            a <- case M.lookup (tripShape trip) shapes of
+            shape <- case M.lookup (tripShape trip) shapes of
               Nothing -> fail $ "trip with id "+|tripTripID trip|+" mentions a shape that does not exist."
-              Just a -> pure a
-            pure $ trip { tripStops = alongRoute, tripShape = a }
+              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."
+              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
+      pushRoute :: Vector (Agency Deep) -> Route Shallow -> IO (Route Deep)
+      pushRoute agencies route = case routeAgency route of
+        Nothing -> do
+          when (V.length agencies /= 1)
+            $ fail $ "route "+|routeId route|+" has no agency_id specified, but there are multiple agencies specified in agency.txt"
+          pure $ route {routeAgency = V.head agencies}
+        Just specifiedId -> case V.headM $ V.filter (\a -> agencyId a == Just specifiedId) agencies of
+          Nothing -> fail $ "route "+|routeId route|+" specifies an agency_id which does not exist."
+          Just agency -> pure $ route { routeAgency = agency }
+
+
       sortShapePoint :: ShapePoint -> Map Text Shape -> Map Text Shape
       sortShapePoint ShapePoint{..} shapes = M.alter appendPoint shapePtId shapes
         where
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 39cdca1..e463195 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -88,17 +88,11 @@ TrainPing json sql=tt_trip_ping
 
 -- status of a train somewhen in time (may be in the future),
 -- inferred from trainpings / entered via controlRoom
-TrainStatus sql=tt_train_status
-  timestamp UTCTime
+TrainAnchor json sql=tt_trip_anchor
   trip TripID
   day Day
+  created UTCTime
   when UTCTime
-  deriving Show Generic Eq ToSchema
-
-TripAnchor json sql=tt_trip_anchor
-  trip TripID
-  day Day
-  timestamp UTCTime
   delay Int Maybe
   msg Text Maybe
   deriving Show Generic Eq ToSchema
diff --git a/lib/Server.hs b/lib/Server.hs
index 75617bd..055925f 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -51,6 +51,8 @@ import           Server.Util                 (Service, ServiceM, runService,
                                               sendErrorMsg)
 import           Yesod                       (toWaiAppPlain)
 
+import           Extrapolation               (Extrapolator (guessAnchor),
+                                              LinearExtrapolator)
 import           System.IO.Unsafe
 
 application :: GTFS -> Pool SqlBackend -> IO Application
@@ -68,7 +70,7 @@ doMigration pool = runSql pool $
 server :: GTFS -> Pool SqlBackend -> Service CompleteAPI
 server gtfs@GTFS{..} dbpool = handleDebugAPI
   :<|> (handleStations :<|> handleTimetable :<|> handleTrip
-        :<|> handleRegister :<|> handleTripPing :<|> handleWS
+        :<|> handleRegister :<|> handleTrainPing :<|> handleWS
         :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister
         :<|> gtfsRealtimeServer gtfs dbpool)
   :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool)))
@@ -94,10 +96,19 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI
           expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
           RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key")
           pure token
-        handleTripPing ping = do
-          lift $ checkTokenValid dbpool (coerce $ trainPingToken ping)
+        handleTrainPing ping = do
+          running@Running{..} <- lift $ checkTokenValid dbpool (coerce $ trainPingToken ping)
+          let anchor = guessAnchor @LinearExtrapolator gtfs running ping
           -- TODO: are these always inserted in order?
-          runSql dbpool $ insert ping
+          runSql dbpool $ do
+            insert ping
+            last <- selectFirst
+              [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay]
+              [Desc TrainAnchorWhen]
+            -- only insert new estimates if they've actually changed anything
+            when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor))
+              $ void $ insert anchor
+
           pure NoContent
         handleWS conn = do
           -- TODO test this!!
@@ -131,13 +142,14 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI
 
 
 -- TODO: proper debug logging for expired tokens
-checkTokenValid :: Pool SqlBackend -> Token -> Handler ()
+checkTokenValid :: Pool SqlBackend -> Token -> Handler Running
 checkTokenValid dbpool token = do
   trip <- try $ runSql dbpool $ get (coerce token)
   when (runningBlocked trip)
     $ throwError err401
   whenM (hasExpired (runningExpires trip))
     $ throwError err401
+  pure trip
   where try m = m >>= \case
           Just a  -> pure a
           Nothing -> throwError err404
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 4ef3784..3c928f1 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -203,6 +203,8 @@ getTrainViewR trip day = do
   <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
+      <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
     $forall Entity (RunningKey key) Running{..} <- tokens
       <tr :runningBlocked:.blocked>
         <td title="#{runningAgent}">#{runningAgent}