aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2022-08-28 17:40:41 +0200
committerstuebinm2022-08-28 17:40:41 +0200
commit1b2e30c134c996e82c282b21099f21501dd966ac (patch)
tree42b9b1d56ed2a75af18689b29c2db5cc06ab0680
parentce20814be8276501d7faa0ef19a8ceebb68283b2 (diff)
this does way too much tbh (also functioning delays)
most of it deals with timezones, and all the weird implications that has
Diffstat (limited to '')
-rw-r--r--lib/API.hs1
-rw-r--r--lib/Extrapolation.hs97
-rw-r--r--lib/GTFS.hs313
-rw-r--r--lib/Persist.hs10
-rw-r--r--lib/Server.hs22
-rw-r--r--lib/Server/ControlRoom.hs2
-rw-r--r--todo.org2
-rw-r--r--tracktrain.cabal3
8 files changed, 351 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}
diff --git a/todo.org b/todo.org
index 1648cdb..f93b149 100644
--- a/todo.org
+++ b/todo.org
@@ -21,6 +21,8 @@
* TODO estimate delays
basically: list of known delays in a db table, either generated from
trip pings & estimates or user-defined in the control room
+** DONE properly handle timezones during gtfs parsing so no one else has to deal with that
+turns out that's impossible, but it looks to be fine the way it is now
* TODO do lots and lots of testing
* IDLE tracker stuff (as website)
diff --git a/tracktrain.cabal b/tracktrain.cabal
index a0e4c13..02eae01 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -97,6 +97,8 @@ library
, yesod-form
, blaze-html
, blaze-markup
+ , timezone-olson
+ , timezone-series
hs-source-dirs: lib
exposed-modules: GTFS
, Server
@@ -104,6 +106,7 @@ library
, Server.ControlRoom
, PersistOrphans
, Persist
+ , Extrapolation
, API
other-modules: Server.Util
default-language: Haskell2010