aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Frontend
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server/Frontend')
-rw-r--r--lib/Server/Frontend/Gtfs.hs57
-rw-r--r--lib/Server/Frontend/OnboardUnit.hs174
-rw-r--r--lib/Server/Frontend/Routes.hs151
-rw-r--r--lib/Server/Frontend/SpaceTime.hs195
-rw-r--r--lib/Server/Frontend/Ticker.hs63
-rw-r--r--lib/Server/Frontend/Tickets.hs404
6 files changed, 1044 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Gtfs.hs b/lib/Server/Frontend/Gtfs.hs
new file mode 100644
index 0000000..bc21ab7
--- /dev/null
+++ b/lib/Server/Frontend/Gtfs.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Gtfs (getGtfsTripViewR, getGtfsTripsViewR) where
+
+import Server.Frontend.Routes
+
+import Data.Functor ((<&>))
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Vector as V
+import qualified GTFS
+import Text.Blaze.Html (Html)
+import Yesod
+
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+ GTFS.GTFS{..} <- getYesod <&> getGtfs
+ defaultLayout $ do
+ setTitle "List of Trips"
+ [whamlet|
+<h1>List of Trips
+<section><ul>
+ $forall trip@GTFS.Trip{..} <- trips
+ <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
+ : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
+|]
+
+
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+ GTFS.GTFS{..} <- getYesod <&> getGtfs
+ case M.lookup tripId trips of
+ Nothing -> notFound
+ Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
+<section>
+ <h2>_{MsgInfo}
+ <p><strong>_{MsgtripId}:</strong> #{tripTripId}
+ <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
+ <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
+<section>
+ <h2>_{MsgStops}
+ <ol>
+ $forall GTFS.Stop{..} <- tripStops
+ <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
+<section>
+ <h2>Dates
+ <ul>
+ TODO!
+|]
+
+mightbe :: Maybe Text -> Text
+mightbe (Just a) = a
+mightbe Nothing = ""
diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs
new file mode 100644
index 0000000..6a8fe6e
--- /dev/null
+++ b/lib/Server/Frontend/OnboardUnit.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.OnboardUnit (getOnboardTrackerR) where
+
+import Server.Frontend.Routes
+
+import Data.Functor ((<&>))
+import qualified Data.Map as M
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import Data.Time (UTCTime (..), getCurrentTime)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.Vector as V
+import qualified GTFS
+import Persist (EntityField (..), Key (..), Stop (..),
+ Ticket (..))
+import Text.Blaze.Html (Html)
+import Yesod
+
+
+getOnboardTrackerR :: Handler Html
+getOnboardTrackerR = do defaultLayout [whamlet|
+ <h1>_{MsgOBU}
+
+ <section>
+ <h2>Tracker
+ <strong>Token:</strong> <span id="token">
+ <section>
+ <h2>Status
+ <p id="status">_{MsgNone}
+ <p id>_{MsgError}: <span id="error">
+ <section>
+ <h2>_{MsgLive}
+ <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
+ <p><strong>Accuracy: </strong><span id="acc">
+ <section>
+ <h2>_{MsgEstimated}
+ <p><strong>_{MsgDelay}</strong>: <span id="delay">
+ <p><strong>_{MsgSequence}</strong>: <span id="sequence">
+
+
+ <script>
+ var token = null;
+
+ let euclid = (a,b) => {
+ let x = a[0]-b[0];
+ let y = a[1]-b[1];
+ return x*x+y*y;
+ }
+
+ let minimalDist = (point, list, proj, norm) => {
+ return list.reduce (
+ (min, x) => {
+ let dist = norm(point, proj(x));
+ return dist < min[0] ? [dist,x] : min
+ },
+ [norm(point, proj(list[0])), list[0]]
+ )[1]
+ }
+
+ let counter = 0;
+ let ws;
+ let id;
+
+ function setStatus(msg) {
+ document.getElementById("status").innerText = msg
+ }
+
+ async function geoError(error) {
+ setStatus("error");
+ alert(`_{MsgPermissionFailed}: \n${error.message}`);
+ console.error(error);
+ main();
+ }
+
+ async function wsError(error) {
+ // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`);
+ console.log(error);
+ navigator.geolocation.clearWatch(id);
+ }
+
+ async function wsClose(error) {
+ console.log(error);
+ document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`;
+ navigator.geolocation.clearWatch(id);
+ setTimeout(openWebsocket, 1000);
+ }
+
+ function wsMsg(msg) {
+ let json = JSON.parse(msg.data);
+ console.log(json);
+ document.getElementById("delay").innerText =
+ `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
+ document.getElementById("sequence").innerText = json.sequence;
+ }
+
+
+ function initGeopos() {
+ document.getElementById("error").innerText = "";
+ id = navigator.geolocation.watchPosition(
+ geoPing,
+ geoError,
+ {enableHighAccuracy: true}
+ );
+ }
+
+
+ function openWebsocket () {
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/tracker/ping/ws");
+ ws.onerror = wsError;
+ ws.onclose = wsClose;
+ ws.onmessage = wsMsg;
+ ws.onopen = (event) => {
+ setStatus("connected");
+ };
+ }
+
+ async function geoPing(geoloc) {
+ console.log("got position update " + counter);
+ document.getElementById("lat").innerText = geoloc.coords.latitude;
+ document.getElementById("long").innerText = geoloc.coords.longitude;
+ document.getElementById("acc").innerText = geoloc.coords.accuracy;
+
+ if (ws !== undefined && ws.readyState == 1) {
+ ws.send(JSON.stringify({
+ token: token,
+ geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ],
+ timestamp: (new Date()).toISOString()
+ }));
+ counter += 1;
+ setStatus(`sent ${counter} pings`);
+ } else {
+ setStatus(`websocket readystate ${ws.readyState}`);
+ }
+ }
+
+
+ async function main() {
+ initGeopos();
+
+ let urlparams = new URLSearchParams(window.location.search);
+
+ token = urlparams.get("token");
+
+ if (token === null) {
+ token = await (await fetch("/api/tracker/register/", {
+ method: "POST",
+ body: JSON.stringify({agent: "tracktrain-website"}),
+ headers: {"Content-Type": "application/json"}
+ })).json();
+
+ if (token.error) {
+ alert("could not obtain token: \n" + token.msg);
+ setStatus("_{MsgTokenFailed}");
+ } else {
+ console.log("got token");
+ window.location.search = `?token=${token}`;
+ }
+ }
+
+ console.log(token)
+
+ if (token !== null) {
+ document.getElementById("token").innerText = token;
+ openWebsocket();
+ }
+ }
+
+ main()
+ |]
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
new file mode 100644
index 0000000..9245e6a
--- /dev/null
+++ b/lib/Server/Frontend/Routes.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Server.Frontend.Routes where
+
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM_)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as LB
+import Data.Functor ((<&>))
+import Data.Pool (Pool)
+import qualified Data.Text as T
+import Data.Time (UTCTime)
+import Data.Time.Calendar (Day)
+import Data.UUID (UUID)
+import Database.Persist.Sql (SqlBackend, runSqlPool)
+import qualified GTFS
+import Persist (Token)
+import Text.Blaze.Internal (MarkupM (Empty))
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.OAuth2.Prelude
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+import Yesod.Orphans ()
+
+data Frontend = Frontend
+ { getGtfs :: GTFS.GTFS
+ , getPool :: Pool SqlBackend
+ , getSettings :: ServerConfig
+ }
+
+mkMessage "Frontend" "messages" "en"
+
+mkYesodData "Frontend" [parseRoutes|
+/ RootR GET
+/auth AuthR Auth getAuth
+
+/tickets TicketsR GET
+/ticket/#UUID TicketViewR GET
+/ticket/map/#UUID TicketMapViewR GET
+/ticket/announce/#UUID AnnounceR POST
+/ticket/del-announce/#UUID DelAnnounceR GET
+
+/ticker/announce TickerAnnounceR POST
+/ticker/delete TickerDeleteR POST
+
+/spacetime SpaceTimeDiagramR GET
+
+/token/block/#Token TokenBlock GET
+
+/gtfs/trips GtfsTripsViewR GET
+/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
+/gtfs/import/#Day GtfsTicketImportR POST
+
+/tracker OnboardTrackerR GET
+|]
+
+emptyMarkup :: MarkupM a -> Bool
+emptyMarkup (Empty _) = True
+emptyMarkup _ = False
+
+
+instance Yesod Frontend where
+ authRoute _ = Just $ AuthR LoginR
+ isAuthorized OnboardTrackerR _ = pure Authorized
+ isAuthorized (AuthR _) _ = pure Authorized
+ isAuthorized _ _ = do
+ maybeUffd <- getYesod <&> serverConfigLogin . getSettings
+ case maybeUffd of
+ Nothing -> pure Authorized
+ Just UffdConfig{..} -> maybeAuthId >>= \case
+ Just _ -> pure Authorized
+ Nothing -> pure AuthenticationRequired
+
+
+ defaultLayout w = do
+ PageContent{..} <- widgetToPageContent w
+ msgs <- getMessages
+
+ withUrlRenderer [hamlet|
+ $newline never
+ $doctype 5
+ <html>
+ <head>
+ <title>
+ $if emptyMarkup pageTitle
+ Tracktrain
+ $else
+ #{pageTitle}
+ $maybe description <- pageDescription
+ <meta name="description" content="#{description}">
+ ^{pageHead}
+ <link rel="stylesheet" href="/assets/style.css">
+ <meta name="viewport" content="width=device-width, initial-scale=1">
+ <body>
+ $forall (status, msg) <- msgs
+ <!-- <p class="message #{status}">#{msg} -->
+ ^{pageBody}
+ |]
+
+
+instance RenderMessage Frontend FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
+instance YesodPersist Frontend where
+ type YesodPersistBackend Frontend = SqlBackend
+ runDB action = do
+ pool <- getYesod <&> getPool
+ runSqlPool action pool
+
+
+-- this instance is only slightly cursed (it keeps login information
+-- as json in a session cookie and hopes nothing will ever go wrong)
+instance YesodAuth Frontend where
+ type AuthId Frontend = UffdUser
+
+ authPlugins cr = case config of
+ Just UffdConfig {..} ->
+ [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
+ Nothing -> []
+ where config = serverConfigLogin (getSettings cr)
+
+ maybeAuthId = do
+ e <- lookupSession "json"
+ pure $ case e of
+ Nothing -> Nothing
+ Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
+
+ authenticate creds = do
+ forM_ (credsExtra creds) (uncurry setSession)
+ -- extra <- lookupSession "extra"
+ -- pure (Authenticated ( undefined))
+ e <- lookupSession "json"
+ case e of
+ Nothing -> error "no session information"
+ Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
+ Nothing -> error "malformed session information"
+ Just user -> pure $ Authenticated user
+
+ loginDest _ = RootR
+ logoutDest _ = RootR
+ -- hardcode redirecting to uffd directly; showing the normal login
+ -- screen is kinda pointless when there's only one option
+ loginHandler = do
+ redirect ("/auth/page/uffd/forward" :: Text)
+ onLogout = do
+ clearSession
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
new file mode 100644
index 0000000..16e8205
--- /dev/null
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where
+
+import Server.Frontend.Routes
+
+import Control.Monad (forM, when)
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
+import Data.Functor ((<&>))
+import Data.Graph (path)
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (Day, UTCTime (..), getCurrentTime)
+import qualified Data.Vector as V
+import Fmt ((+|), (|+))
+import GHC.Float (double2Int, int2Double)
+import GTFS (Seconds (unSeconds))
+import qualified GTFS
+import Persist
+import Server.Util (getTzseries)
+import Text.Blaze.Html (Html)
+import Text.Read (readMaybe)
+import Yesod
+
+getSpaceTimeDiagramR :: Handler Html
+getSpaceTimeDiagramR = do
+ req <- getRequest
+ day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of
+ Just day -> pure day
+ Nothing -> liftIO $ getCurrentTime <&> utctDay
+
+ mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] >>= \case
+ Nothing -> notFound
+ Just widget -> defaultLayout [whamlet|
+ <h1>_{MsgSpaceTimeDiagram}
+ <section>
+ ^{widget}
+ |]
+
+mkSpaceTimeDiagramHandler :: Double -> Day -> [Filter Ticket] -> Handler (Maybe Widget)
+mkSpaceTimeDiagramHandler scale day filter = do
+ tickets <- runDB $ selectList filter [ Asc TicketId ] >>= mapM (\ticket -> do
+ stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
+ arrival <- lift $ timeToPos scale day stopArrival
+ departure <- lift $ timeToPos scale day stopDeparture
+ pure (stop, arrival, departure))
+ anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
+ pure (ticket, stops, anchors))
+
+ case tickets of
+ [] ->
+ pure Nothing
+ _ ->
+ mkSpaceTimeDiagram scale day tickets
+ <&> Just
+
+-- | Safety: tickets may not be empty
+mkSpaceTimeDiagram
+ :: Double
+ -> Day
+ -> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])]
+ -> Handler Widget
+mkSpaceTimeDiagram scale day tickets = do
+ -- we take the longest trip of the day. This will lead to unreasonable results
+ -- if there's more than one shape (this whole route should probably take a shape id tbh)
+ stations <- runDB $ fmap (\(_,stops,_) -> stops) tickets
+ & maximumBy (compare `on` length)
+ & fmap (\(stop, _, _) -> stop)
+ & sortOn stopSequence
+ & zip [0..]
+ & mapM (\(idx, stop) -> do
+ station <- getJust (stopStation stop)
+ pure (station, stop { stopSequence = idx }))
+
+ let reference = stations
+ <&> \(_, stop) -> stop
+ let maxSequence = stopSequence (last reference)
+ let scaleSequence a = a * 100 / int2Double maxSequence
+
+
+ (minY, maxY) <- tickets
+ <&> (\(_,stops,_) -> stops)
+ & concat
+ & mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop))
+ <&> (\ys -> (minimum ys - 10, maximum ys + 30))
+
+ let timezone = head reference
+ & stopArrival
+ & GTFS.tzname
+
+ timeLines <- ([0,(double2Int $ 3600 / scale)..(24*3600)]
+ & mapM ((\a -> timeToPos scale day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
+ <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst)
+
+ pure [whamlet|
+ <svg viewBox="-6 #{minY} 108 #{maxY - minY}" width="100%">
+
+ -- horizontal lines per hour
+ $forall (y, time) <- timeLines
+ <path
+ style="fill:none;stroke:grey;stroke-width:0.2;stroke-dasharray:1"
+ d="M 0,#{y} 100,#{y}"
+ >
+ <text style="font-size:1pt;">
+ <tspan x="-5" y="#{y + 0.1}">#{time}
+
+ -- vertical lines per station
+ $forall (station, Stop{..}) <- stations
+ <path
+ style="fill:none;stroke:#79797a;stroke-width:0.3"
+ d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
+ >
+ <text style="font-size:2pt;" transform="rotate(-90)">
+ <tspan
+ x="#{0 - maxY}"
+ y="#{scaleSequence (int2Double stopSequence) - 0.5}"
+ >#{stationName station}
+
+ -- trips
+ $forall (ticket, stops, anchors) <- tickets
+ <path
+ style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
+ d="M #{mkStopsline scaleSequence reference stops}"
+ >
+ <path
+ style="fill:none;stroke:red;stroke-width:0.3;"
+ d="M #{mkAnchorline scale scaleSequence reference stops anchors}"
+ >
+ |]
+
+mkStopsline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> Text
+mkStopsline scaleSequence reference stops = stops
+ <&> mkStop
+ & T.concat
+ where mkStop (stop, arrival, departure) =
+ " "+|scaleSequence s|+","+|arrival|+" "
+ +|scaleSequence s|+","+|departure|+""
+ where s = mapSequenceWith reference stop & int2Double
+
+mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scale scaleSequence reference stops anchors =
+ anchors
+ <&> (mkAnchor . entityVal)
+ & T.concat
+ where
+ mkAnchor TrainAnchor{..} =
+ " "+|scaleSequence transformed|+","
+ -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
+ +|secondsToPos scale trainAnchorWhen|+""
+ where
+ transformed = int2Double (mapSequence lastStop) + offset
+
+ offset =
+ abs (trainAnchorSequence - int2Double (stopSequence lastStop))
+ / int2Double (stopSequence lastStop - stopSequence nextStop)
+ -- the below is necessary to flip if necessary (it can be either -1 or +1)
+ * int2Double (mapSequence lastStop - mapSequence nextStop)
+
+ mapSequence = mapSequenceWith reference
+
+ lastStop = stops
+ & filter (\(Stop{..},_,_) ->
+ int2Double stopSequence <= trainAnchorSequence)
+ & last
+ & \(stop,_,_) -> stop
+ nextStop = stops
+ & filter (\(Stop{..},_,_) ->
+ int2Double stopSequence > trainAnchorSequence)
+ & head
+ & \(stop,_,_) -> stop
+
+-- | map a stop sequence number into the graph's space
+mapSequenceWith :: [Stop] -> Stop -> Int
+mapSequenceWith reference stop = filter
+ (\referenceStop -> stopStation referenceStop == stopStation stop) reference
+ & head
+ & stopSequence
+
+-- | SAFETY: ignores time zones
+secondsToPos :: Double -> Seconds -> Double
+secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds
+
+timeToPos :: Double -> Day -> GTFS.Time -> Handler Double
+timeToPos scale day time = do
+ settings <- getYesod <&> getSettings
+ tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
+ pure $ secondsToPos scale (GTFS.toSeconds time tzseries day)
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs
new file mode 100644
index 0000000..861197a
--- /dev/null
+++ b/lib/Server/Frontend/Ticker.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where
+import Data.Functor ((<&>))
+import Data.Time (getCurrentTime)
+import Persist (EntityField (TickerAnnouncementArchived),
+ TickerAnnouncement (..))
+import Server.Frontend.Routes (FrontendMessage (..), Handler,
+ Route (..), Widget)
+import Yesod
+
+
+tickerAnnounceForm
+ :: Maybe TickerAnnouncement
+ -> Html
+ -> MForm Handler (FormResult TickerAnnouncement, Widget)
+tickerAnnounceForm maybeCurrent = renderDivs $ TickerAnnouncement
+ <$> areq textField (fieldSettingsLabel MsgHeader)
+ (maybeCurrent <&> tickerAnnouncementHeader)
+ <*> fmap unTextarea (areq textareaField (fieldSettingsLabel MsgText)
+ (maybeCurrent <&> (Textarea . tickerAnnouncementMessage)))
+ <*> pure False
+ <*> lift (liftIO getCurrentTime)
+
+tickerWidget :: Handler Html
+tickerWidget = do
+ current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
+
+ (widget, enctype) <-
+ generateFormPost (tickerAnnounceForm (current <&> entityVal))
+
+ defaultLayout [whamlet|
+ <h2>_{Msgincident}
+ <form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+ <form method=post action=@{TickerDeleteR}>
+ <button>_{Msgdelete}
+ |]
+
+postTickerAnnounceR :: Handler Html
+postTickerAnnounceR = do
+ current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
+ ((result, widget), enctype) <-
+ runFormPost (tickerAnnounceForm (current <&> entityVal))
+ case result of
+ FormSuccess ann -> do
+ runDB $ do
+ updateWhere [] [ TickerAnnouncementArchived =. True ]
+ insert ann
+ redirect RootR
+ _ -> defaultLayout
+ [whamlet|
+ <p>_{MsgInvalidInput}.
+ <form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+ |]
+
+postTickerDeleteR :: Handler Html
+postTickerDeleteR = do
+ runDB $ updateWhere [] [ TickerAnnouncementArchived =. True ]
+ redirect RootR
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
new file mode 100644
index 0000000..9b88a48
--- /dev/null
+++ b/lib/Server/Frontend/Tickets.hs
@@ -0,0 +1,404 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Tickets
+ ( getTicketsR
+ , postGtfsTicketImportR
+ , getTicketViewR
+ , getTicketMapViewR
+ , getDelAnnounceR
+ , postAnnounceR
+ , getTokenBlock
+ ) where
+
+import Server.Frontend.Routes
+
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM, forM_, join)
+import Control.Monad.Extra (maybeM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
+import Data.Functor ((<&>))
+import Data.List (lookup, nubBy)
+import Data.List.NonEmpty (nonEmpty)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromJust, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (UTCTime (..), addDays,
+ getCurrentTime, utctDay)
+import Data.Time.Calendar (Day)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.Vector as V
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..))
+import Fmt ((+|), (|+))
+import GHC.Float (int2Double)
+import qualified GTFS
+import Numeric (showFFloat)
+import Persist
+import Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
+ mkSpaceTimeDiagramHandler)
+import Server.Frontend.Ticker (tickerWidget)
+import Server.Util (Service, secondsNow)
+import Text.Read (readMaybe)
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+
+
+getTicketsR :: Handler Html
+getTicketsR = do
+ req <- getRequest
+ let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
+ mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
+
+ (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today ->
+ case maybeDay of
+ Just day -> (day, day == today)
+ Nothing -> (today, True)
+
+ maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ]
+
+ let prevday = (T.pack . iso8601Show . addDays (-1)) day
+ let nextday = (T.pack . iso8601Show . addDays 1) day
+ gtfs <- getYesod <&> getGtfs
+
+ -- TODO: tickets should have all trip information saved
+ tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketTripName ] >>= mapM (\ticket -> do
+ stops <- selectList [ StopTicket ==. entityKey ticket ] []
+ startStation <- getJust (stopStation $ entityVal $ head stops)
+ pure (ticket, startStation, fmap entityVal stops))
+
+ let trips = GTFS.tripsOnDay gtfs day
+
+ tickerAnnounceWidget <- tickerWidget
+
+ (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+ defaultLayout $ do
+ [whamlet|
+<h1> _{MsgTrainsOnDay (iso8601Show day)}
+$maybe name <- mdisplayname
+ <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
+<nav>
+ <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday}
+ $if isToday
+ _{Msgtoday}
+ $else
+ <a href="@{TicketsR}">_{Msgtoday}
+ <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
+<section>
+ ^{tickerAnnounceWidget}
+<section>
+ <h2>_{MsgTickets}
+ <ol>
+ $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets
+ <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
+ : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
+ $if null tickets
+ <li style="text-align: center"><em>(_{MsgNone})</em>
+$maybe spaceTime <- maybeSpaceTime
+ <section>
+ ^{spaceTime}
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
+ $if null trips
+ <li style="text-align: center"><em>(_{MsgNone})
+|]
+
+
+-- TODO: this function should probably look for duplicate imports
+postGtfsTicketImportR :: Day -> Handler Html
+postGtfsTicketImportR day = do
+ gtfs <- getYesod <&> getGtfs
+ let trips = GTFS.tripsOnDay gtfs day
+ ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+ case result of
+ FormSuccess selected -> do
+ now <- liftIO getCurrentTime
+
+ shapeMap <- selected
+ <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape))
+ & nubBy ((==) `on` fst)
+ & mapM (\(shapeId, shape) -> runDB $ do
+ key <- insert Shape
+ insertMany
+ $ shape
+ & GTFS.shapePoints
+ & V.indexed
+ & V.toList
+ <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key
+ pure (shapeId, key))
+ <&> M.fromList
+
+ stationMap <- selected
+ <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation))
+ & concat
+ & nubBy ((==) `on` GTFS.stationId)
+ & mapM (\GTFS.Station{..} -> runDB $ do
+ maybeExists <- selectFirst [ StationShortName ==. stationId ] []
+ case maybeExists of
+ Nothing -> do
+ key <- insert Station
+ { stationGeopos = Geopos (stationLat, stationLon)
+ , stationShortName = stationId , stationName }
+ pure (stationId, key)
+ Just (Entity key _) -> pure (stationId, key))
+ <&> M.fromList
+
+ selected
+ <&> (\(trip@GTFS.Trip{..}, day) ->
+ let
+ ticket = Ticket
+ { ticketTripName = tripTripId, ticketDay = day, ticketImported = now
+ , ticketSchedule_version = Nothing, ticketVehicle = Nothing
+ , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip
+ , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)}
+ stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop
+ { stopTicket = ticketId
+ , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap)
+ , stopArrival, stopDeparture, stopSequence}
+ in (ticket, stops))
+ & unzip
+ & \(tickets, stops) -> runDB $ do
+ ticketIds <- insertMany tickets
+ forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) ->
+ insertMany (fmap (\s -> s ticketId) unfinishedStops)
+
+ redirect (TicketsR, [("day", T.pack (iso8601Show day))])
+
+ FormFailure _ -> defaultLayout [whamlet|
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+ let ticketKey = TicketKey ticketId
+ Ticket{..} <- runDB $ get ticketKey
+ >>= \case {Nothing -> notFound; Just a -> pure a}
+
+ stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
+ station <- getJust (stopStation (entityVal stop))
+ pure (entityVal stop, station))
+
+ anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+ joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+ <&> fmap (trackerTicketTracker . entityVal)
+ trackers <- runDB $ selectList
+ ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ])
+ [Asc TrackerExpires]
+ lastPing <- runDB $ selectFirst [ TrainPingTicket ==. coerce ticketId ] [Desc TrainPingTimestamp]
+ anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
+ <&> nonEmpty . fmap entityVal
+
+ spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId ==. coerce ticketId ]
+
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+
+ nowSeconds <- secondsNow ticketDay
+ defaultLayout $ do
+ mr <- getMessageRender
+ setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
+ [whamlet|
+<h1>_{MsgTrip} #
+ <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName}
+ _{Msgon}
+ <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}
+<section>
+ <h2>_{MsgLive}
+ <p><strong>_{MsgLastPing}: </strong>
+ $maybe Entity _ TrainPing{..} <- lastPing
+ _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
+ (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
+ $nothing
+ <em>(_{MsgNoTrainPing})
+ <p><strong>_{MsgEstimatedDelay}</strong>:
+ $maybe history <- anchors
+ $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds
+ \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
+ $nothing
+ <em> (_{MsgNone})
+ <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a>
+<section>
+ <h2>_{MsgStops}
+ <ol>
+ $forall (Stop{..}, Station{..}) <- stops
+ <li value="#{stopSequence}"> #{stopArrival} #{stationName}
+ $maybe history <- anchors
+ $maybe delay <- guessDelay history (int2Double stopSequence)
+ \ (#{delay})
+$maybe spaceTime <- spaceTimeMaybe
+ <section>
+ ^{spaceTime}
+<section>
+ <h2>_{MsgAnnouncements}
+ <ul>
+ $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
+ <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 ticketId} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+<section>
+ <h2>_{MsgTokens}
+ <table>
+ <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
+ $if null trackers
+ <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
+ $forall Entity (TrackerKey key) Tracker{..} <- trackers
+ <tr :trackerBlocked:.blocked>
+ <td title="#{trackerAgent}">#{trackerAgent}
+ <td title="#{key}">#{key}
+ <td title="#{trackerExpires}">#{trackerExpires}
+ $if trackerBlocked
+ <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
+ $else
+ <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
+|]
+ where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history
+ guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
+
+
+getTicketMapViewR :: UUID -> Handler Html
+getTicketMapViewR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId)
+ >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
+
+ stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do
+ station <- getJust (stopStation (entityVal stop))
+ pure (entityVal stop, station))
+
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+
+ defaultLayout [whamlet|
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a>
+<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
+ integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
+ crossorigin=""/>
+<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js"
+ integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM="
+ crossorigin=""></script>
+<div id="map">
+<p id="status">
+<script>
+ let map = L.map('map');
+
+ L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', {
+ attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
+ }).addTo(map);
+
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/ticket/subscribe/#{UUID.toText ticketId}");
+
+ var marker = null;
+
+ ws.onmessage = (msg) => {
+ let json = JSON.parse(msg.data);
+ console.log(json)
+ if (marker === null) {
+ marker = L.marker(json.geopos);
+ marker.addTo(map);
+ } else {
+ marker.setLatLng(json.geopos);
+ }
+ map.setView(json.geopos, 13);
+ document.getElementById("status").innerText = "_{MsgLastPing}: "+json.geopos[0]+","+json.geopos[1]+" ("+json.timestamp+")";
+ }
+|]
+
+tripImportForm
+ :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
+ -> Html
+ -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
+tripImportForm trips extra = do
+ forms <- forM trips $ \(trip, day) -> do
+ (aRes, aView) <- mreq checkBoxField "import" Nothing
+ let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+ pure (trip, day, dings, aView)
+
+ let widget = toWidget [whamlet|
+ #{extra}
+ <ol>
+ $forall (trip@GTFS.Trip{..}, day, res, view) <- forms
+ <li>
+ ^{fvInput view}
+ <label for="^{fvId view}">
+ _{MsgTrip} #{GTFS.tripName trip}
+ : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
+ |]
+
+ let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
+ sequenceA (fmap (\(_,_,res,_) -> res) forms)
+
+ pure (fmap catMaybes a, widget)
+
+gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
+gtfsHeadsign GTFS.Trip{..} =
+ case tripHeadsign of
+ Just headsign -> headsign
+ Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops))
+
+
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+ <$> pure (TicketKey ticketId)
+ <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
+ <*> areq textField (fieldSettingsLabel MsgText) Nothing
+ <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
+ <*> lift (liftIO getCurrentTime <&> Just)
+
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+ ((result, widget), enctype) <- runFormPost (announceForm ticketId)
+ case result of
+ FormSuccess ann -> do
+ runDB $ insert ann
+ redirect RootR -- (TicketViewR trip day)
+ _ -> defaultLayout
+ [whamlet|
+ <p>_{MsgInvalidInput}.
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+ |]
+
+getDelAnnounceR :: UUID -> Handler Html
+getDelAnnounceR uuid = do
+ ann <- runDB $ do
+ a <- get (AnnouncementKey uuid)
+ delete (AnnouncementKey uuid)
+ pure a
+ case ann of
+ Nothing -> notFound
+ Just Announcement{..} ->
+ let (TicketKey ticketId) = announcementTicket
+ in redirect (TicketViewR ticketId)
+
+getTokenBlock :: Token -> Handler Html
+getTokenBlock token = do
+ YesodRequest{..} <- getRequest
+ let blocked = lookup "unblock" reqGetParams /= Just "true"
+ maybe <- runDB $ do
+ update (TrackerKey token) [ TrackerBlocked =. blocked ]
+ get (TrackerKey token)
+ case maybe of
+ Just r@Tracker{..} -> do
+ liftIO $ print r
+ redirect $ case trackerCurrentTicket of
+ Just ticket -> TicketViewR (coerce ticket)
+ Nothing -> RootR
+ Nothing -> notFound
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-07 02:44:57 +0000