diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/GTFS.hs | 14 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 84 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 16 |
3 files changed, 84 insertions, 30 deletions
diff --git a/lib/GTFS.hs b/lib/GTFS.hs index af4d03b..2bcfdd5 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -153,8 +153,18 @@ instance Show Time where show (Time seconds _ _) = "" +|pad (seconds `div` 3600)|+":" +|pad ((seconds `mod` 3600) `div` 60)|+ - {- if seconds `mod` 60 /= 0 then -}":"+|pad (seconds `mod` 60)|+"" - -- else "" + if seconds `mod` 60 /= 0 then":"+|pad (seconds `mod` 60)|+"" + else "" + where + pad num = + if length str < 2 then "0"<>str else str + where str = show num + +showTimeWithSeconds :: Time -> String +showTimeWithSeconds (Time seconds _ _) = "" + +|pad (seconds `div` 3600)|+":" + +|pad ((seconds `mod` 3600) `div` 60)|+ + ":"+|pad (seconds `mod` 60)|+"" where pad num = if length str < 2 then "0"<>str else str diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index f08abcb..2be0b3e 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -32,7 +32,7 @@ import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T import Data.Time (UTCTime (..), getCurrentTime, - utctDay) + utctDay, addDays) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) @@ -125,10 +125,14 @@ instance Yesod ControlRoom where <meta name="description" content="#{description}"> ^{pageHead} <style> + html { + overflow-x: hidden + } section { - border: 1px solid black; + border: 0.1rem solid black; padding: 1rem; - margin: 2rem; + margin: 2vw; + margin-top: 0; padding-top: 0; } body { @@ -158,9 +162,34 @@ instance Yesod ControlRoom where width: 100%; height: 50vh; } + nav { + padding: 0.5em; + position: relative; + text-align: center; + margin-left: 2vw; + margin-right: 2vw; + margin-top: 2rem; + } + .nav-left { + position: absolute; + left: 0; + } + .nav-right { + position: absolute; + right: 0; + } + ol { + padding: 0 + } + li { + list-style: none; + margin: 0.5vw; + border-bottom: 0.1rem black dashed; + padding-bottom: 0.5rem; + } <body> $forall (status, msg) <- msgs - <p class="message #{status}">#{msg} + <!-- <p class="message #{status}">#{msg} --> ^{pageBody} |] @@ -193,8 +222,7 @@ instance YesodAuth ControlRoom where Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) authenticate creds = do - forM_ (credsExtra creds) $ \(key, val) -> - setSession key val + forM_ (credsExtra creds) (uncurry setSession) -- extra <- lookupSession "extra" -- pure (Authenticated ( undefined)) e <- lookupSession "json" @@ -225,18 +253,34 @@ getTrainsR = do let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) mdisplayname <- maybeAuthId <&> fmap uffdDisplayName - day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) + (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today -> + case maybeDay of + Just day -> (day, day == today) + Nothing -> (today, True) + + let prevday = (T.pack . iso8601Show . addDays (-1)) day + let nextday = (T.pack . iso8601Show . addDays 1) day gtfs <- getYesod <&> getGtfs let trips = tripsOnDay gtfs day defaultLayout $ do [whamlet| -<h1>Trains on #{day} +<h1> _{MsgTrainsOnDay (iso8601Show day)} $maybe name <- mdisplayname <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a> -<section><ol> - $forall trip@Trip{..} <- trips - <li><a href="@{TrainViewR tripTripID day}">#{tripName trip}</a> - : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} +<nav> + <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday} + $if isToday + _{Msgtoday} + $else + <a href="@{TrainsR}">_{Msgtoday} + <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} → +<section> + <ol> + $forall trip@Trip{..} <- trips + <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a> + : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} + $if null trips + <li style="text-align: center"><em>(_{MsgNone}) |] getTrainViewR :: TripID -> Day -> Handler Html @@ -284,13 +328,13 @@ getTrainViewR trip day = do <h2>_{MsgAnnouncements} <ul> $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns - <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">delete</a> + <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">_{Msgdelete}</a> $if null anns <li><em>(_{MsgNone})</em> <h3>_{MsgNewAnnouncement} <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> ^{widget} - <button>Submit + <button>_{MsgSubmit} <section> <h2>_{MsgTokens} <table> @@ -317,7 +361,7 @@ getTrainMapViewR tripId day = do (widget, enctype) <- generateFormPost (announceForm day tripId) case M.lookup tripId trips of Nothing -> notFound - Just res@Trip{..} -> do defaultLayout $ [whamlet| + Just res@Trip{..} -> do defaultLayout [whamlet| <h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a> <link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css" integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI=" @@ -373,14 +417,14 @@ getTripViewR tripId = do case M.lookup tripId trips of Nothing -> notFound Just trip@Trip{..} -> defaultLayout [whamlet| -<h1>Trip #{tripName trip} +<h1>_{MsgTrip} #{tripName trip} <section> - <h2>Info + <h2>_{MsgInfo} <p><strong>_{MsgtripId}:</strong> #{tripTripID} <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign} <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName} <section> - <h2>Stops + <h2>_{MsgStops} <ol> $forall Stop{..} <- tripStops <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} @@ -400,10 +444,10 @@ postAnnounceR trip day = do redirect (TrainViewR trip day) _ -> defaultLayout [whamlet| - <p>Invalid input, let's try again. + <p>_{MsgInvalidInput}. <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> ^{widget} - <button>Submit + <button>_{MsgSubmit} |] getDelAnnounceR :: UUID -> Handler Html diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 42af09b..984e19d 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -91,7 +91,7 @@ import Data.UUID (t import qualified Data.Vector as V import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds), LinearExtrapolator (..)) -import GTFS (Depth (..)) +import GTFS (Depth (..), showTimeWithSeconds) import GTFS.Realtime.TripUpdate (TripUpdate (TripUpdate)) import Server.Util (Service, secondsNow) @@ -163,11 +163,11 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = handleServiceAlerts :<|> handleTripUpd where mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) = let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds stations = tripStops - <&> (\stop@Stop{..} -> fmap (, stop) $ extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence)) + <&> (\stop@Stop{..} -> (, stop) <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence)) -- note: these IDs should be stable across iterations, so just do tripId + runningday. TODO: breaks in case of cross-midnight? - in (dFeedEntity (Utf8 $ fromStrict $ (encodeUtf8 tripId <> "-" <> (C8.pack $ iso8601Show today)))) + in (dFeedEntity (Utf8 $ fromStrict (encodeUtf8 tripId <> "-" <> C8.pack (iso8601Show today)))) { FE.trip_update = Just $ TripUpdate - { TU.trip = dTripDescriptor tripId (Just today) (Just $ toUtf8 $ T.pack $ show $ stopDeparture $ V.head tripStops) -- TODO will break if cross-midnight train + { TU.trip = dTripDescriptor tripId (Just today) (Just $ toUtf8 $ T.pack $ showTimeWithSeconds $ stopDeparture $ V.head tripStops) -- TODO will break if cross-midnight train , TU.vehicle = Nothing , TU.stop_time_update = Seq.fromList $ fmap (\(TrainAnchor{..}, Stop{..}) -> StopTimeUpdate @@ -175,13 +175,13 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = handleServiceAlerts :<|> handleTripUpd , STU.stop_id = Just (toUtf8 $ stationId stopStation) , STU.arrival = Just ( defaultValue - { STE.delay = Just $ fromIntegral $ unSeconds $ trainAnchorDelay - , STE.time = Just $ (toStupidTime (addUTCTime (fromIntegral $ unSeconds trainAnchorDelay) (toUTC stopArrival tzseries today))) + { STE.delay = Just $ fromIntegral $ unSeconds trainAnchorDelay + , STE.time = Just $ toStupidTime (addUTCTime (fromIntegral $ unSeconds trainAnchorDelay) (toUTC stopArrival tzseries today)) , STE.uncertainty = Just 60 }) , STU.departure = Just ( defaultValue - { STE.delay = Just $ fromIntegral $ unSeconds $ trainAnchorDelay - , STE.time = Just $ (toStupidTime (addUTCTime (fromIntegral $ unSeconds trainAnchorDelay) (toUTC stopDeparture tzseries today))) + { STE.delay = Just $ fromIntegral $ unSeconds trainAnchorDelay + , STE.time = Just $ toStupidTime (addUTCTime (fromIntegral $ unSeconds trainAnchorDelay) (toUTC stopDeparture tzseries today)) , STE.uncertainty = Just 60 }) , STU.departure_occupancy_status = Nothing , STU.schedule_relationship = Just SR.SCHEDULED |