better web interface & css

author: stuebinm 2023-01-28 21:10:14 +0100
committer: stuebinm 2023-01-28 21:10:14 +0100
commit: 1612bb5aec55af06f66012ff2627f533e7a57c67 (patch)
tree: d31f0095afcfb3f535dd5d49b8045f85d338d1b9
parent: 9d0cbb1703114140cf940ac6e3f4a3e9b730d40e (diff)
5 files changed, 108 insertions, 31 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
diff --git a/messages/de.msg b/messages/de.msg
index 92450f2..016ebbb 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -7,14 +7,26 @@ LoggedInAs name: Angemeldet als #{name}
 Logout: Abmelden
 MaybeWeblink: Link (optional)
 TripOnDay tripId day: #{tripId} an #{day}
+TrainsOnDay day: Fahrten am #{day}
+today: heute
 on: am
 Trip: Fahrt
+tripId: Fahrtnummer
+tripHeadsign: Anzeige
+tripShortname: Name
+dep: ab
+Info: Info
 SwitchLanguage: Sprache wechseln
 Switch: wechseln
 Stops: Stationen
 Tokens: Token
+BlockToken: blockieren
+UnblockToken: zulassen
+Token: Token
+Status: Status
 Expires: läuft ab
-Live: Echtzeitdaten
+Agent: Gerät
+Live: Echtzeit
 LastPing: Letzte Meldung
 TrainPing lat long time: #{lat},#{long}, um #{time}
 NoTrainPing: keine empfangen
@@ -22,7 +34,11 @@ raw: roh
 EstimatedDelay: Geschätzte Verspätung
 OnStationSequence idx: an Stationsindex #{idx}
 Map: Karte
+InvalidInput: Ungültige Eingabe, bitte noch einmal
+Submit: Ok
+delete: löschen
 
+OBU: Onboard-Unit
 ChooseTrain: Fahrt auswählen
 TokenFailed: konnte kein Token erhalten
 PermissionFailed: Berechtigungsfehler
diff --git a/messages/en.msg b/messages/en.msg
index 184a64d..ecaad0a 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -7,11 +7,15 @@ LoggedInAs name@Text: Logged in as #{name}
 Logout: Log out
 MaybeWeblink: Link (optional)
 TripOnDay tripId@Text day@String: #{tripId} on #{day}
+TrainsOnDay day@String: Trains on #{day}
+today: today
 on: on
 Trip: Trip
 tripId: Trip Id
 tripHeadsign: Headsign
 tripShortname: Short Name
+dep: dep.
+Info: Info
 SwitchLanguage: Switch language to:
 Switch: Switch
 Stops: Stops
@@ -30,6 +34,9 @@ raw: raw
 EstimatedDelay: Estimated Delay
 OnStationSequence idx@String: on station index #{idx}
 Map: Map
+InvalidInput: Invalid input, let's try again
+Submit: Submit
+delete: delete
 
 OBU: Onboard-Unit
 ChooseTrain: Choose a Train
author	stuebinm	2023-01-28 21:10:14 +0100
committer	stuebinm	2023-01-28 21:10:14 +0100
commit	1612bb5aec55af06f66012ff2627f533e7a57c67 (patch)
tree	d31f0095afcfb3f535dd5d49b8045f85d338d1b9
parent	9d0cbb1703114140cf940ac6e3f4a3e9b730d40e (diff)