diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 1 | ||||
| -rw-r--r-- | lib/Extrapolation.hs | 97 | ||||
| -rw-r--r-- | lib/GTFS.hs | 313 | ||||
| -rw-r--r-- | lib/Persist.hs | 10 | ||||
| -rw-r--r-- | lib/Server.hs | 22 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 2 | ||||
| -rw-r--r-- | todo.org | 2 | ||||
| -rw-r--r-- | tracktrain.cabal | 3 |
8 files changed, 351 insertions, 99 deletions
@@ -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} @@ -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 |