aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/ControlRoom.hs84
-rw-r--r--lib/Server/GTFS_RT.hs16
2 files changed, 72 insertions, 28 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-20 06:09:01 +0000