From dc519ae889ab40fe1723cd601c3e79b73bdd2f51 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 8 May 2024 23:34:43 +0200
Subject: restructure: split web frontend into several modules
---
lib/Server.hs | 4 +-
lib/Server/ControlRoom.hs | 605 -------------------------------------
lib/Server/Frontend.hs | 20 ++
lib/Server/Frontend/Gtfs.hs | 57 ++++
lib/Server/Frontend/OnboardUnit.hs | 174 +++++++++++
lib/Server/Frontend/Routes.hs | 145 +++++++++
lib/Server/Frontend/Tickets.hs | 386 +++++++++++++++++++++++
site/obu.hamlet | 132 --------
site/tracker.hamlet | 147 ---------
tracktrain.cabal | 9 +-
10 files changed, 792 insertions(+), 887 deletions(-)
delete mode 100644 lib/Server/ControlRoom.hs
create mode 100644 lib/Server/Frontend.hs
create mode 100644 lib/Server/Frontend/Gtfs.hs
create mode 100644 lib/Server/Frontend/OnboardUnit.hs
create mode 100644 lib/Server/Frontend/Routes.hs
create mode 100644 lib/Server/Frontend/Tickets.hs
delete mode 100644 site/obu.hamlet
delete mode 100644 site/tracker.hamlet
diff --git a/lib/Server.hs b/lib/Server.hs
index 1833aa0..055e440 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -40,7 +40,7 @@ import Servant.API ((:<|>) (..))
import Servant.Server (hoistServer)
import Servant.Swagger (toSwagger)
import Server.Base (ServerState)
-import Server.ControlRoom (ControlRoom (ControlRoom))
+import Server.Frontend (Frontend (..))
import Server.GTFS_RT (gtfsRealtimeServer)
import Server.Ingest (handleTrackerRegister,
handleTrainPing, handleWS)
@@ -82,7 +82,7 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI
:<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool)
:<|> handleMetrics
:<|> serveDirectoryFileServer (serverConfigAssets settings)
- :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings)))
+ :<|> pure (unsafePerformIO (toWaiAppPlain (Frontend gtfs dbpool settings)))
where
handleDebugState = do
now <- liftIO getCurrentTime
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
deleted file mode 100644
index 5292620..0000000
--- a/lib/Server/ControlRoom.hs
+++ /dev/null
@@ -1,605 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Server.ControlRoom (ControlRoom(..)) where
-
-import Config (ServerConfig (..), UffdConfig (..))
-import Control.Monad (forM, forM_, join)
-import Control.Monad.Extra (maybeM)
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import qualified Data.Aeson as A
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy as LB
-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.Pool (Pool)
-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 Database.Persist (Entity (..), delete, entityVal, get,
- insert, selectList, (==.))
-import Database.Persist.Sql (PersistFieldSql, SqlBackend,
- runSqlPool)
-import Extrapolation (Extrapolator (..),
- LinearExtrapolator (..))
-import Fmt ((+|), (|+))
-import GHC.Float (int2Double)
-import GHC.Generics (Generic)
-import qualified GTFS
-import Numeric (showFFloat)
-import Persist
-import Server.Util (Service, secondsNow)
-import Text.Blaze.Html (ToMarkup (..))
-import Text.Blaze.Internal (MarkupM (Empty))
-import Text.Read (readMaybe)
-import Text.Shakespeare.Text
-import Yesod
-import Yesod.Auth
-import Yesod.Auth.OAuth2.Prelude
-import Yesod.Auth.OpenId (IdentifierType (..), authOpenId)
-import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
-import Yesod.Form
-import Yesod.Orphans ()
-
-
-data ControlRoom = ControlRoom
- { getGtfs :: GTFS.GTFS
- , getPool :: Pool SqlBackend
- , getSettings :: ServerConfig
- }
-
-mkMessage "ControlRoom" "messages" "en"
-
-mkYesod "ControlRoom" [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
-
-/token/block/#Token TokenBlock GET
-
-/gtfs/trips GtfsTripsViewR GET
-/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
-/gtfs/import/#Day GtfsTicketImportR POST
-
-/obu OnboardUnitMenuR GET
-/obu/#UUID OnboardUnitR GET
-/tracker OnboardTrackerR GET
-|]
-
-emptyMarkup :: MarkupM a -> Bool
-emptyMarkup (Empty _) = True
-emptyMarkup _ = False
-
-instance Yesod ControlRoom where
- authRoute _ = Just $ AuthR LoginR
- isAuthorized OnboardUnitMenuR _ = pure Authorized
- isAuthorized (OnboardUnitR _) _ = pure Authorized
- isAuthorized OnboardTrackerR _ = pure Authorized
- isAuthorized (AuthR _) _ = pure Authorized
- isAuthorized _ _ = do
- UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
- if uffdConfigEnable then maybeAuthId >>= \case
- Just _ -> pure Authorized
- Nothing -> pure AuthenticationRequired
- else pure Authorized
-
-
- 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 ControlRoom FormMessage where
- renderMessage _ _ = defaultFormMessage
-
-instance YesodPersist ControlRoom where
- type YesodPersistBackend ControlRoom = 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 ControlRoom where
- type AuthId ControlRoom = UffdUser
-
- authPlugins cr = case config of
- UffdConfig {..} -> if uffdConfigEnable
- then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
- else []
- 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
-
-
-
-
-getRootR :: Handler Html
-getRootR = redirect TicketsR
-
-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)
-
- 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
-
- (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>
- <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>
-<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 [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
- anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
- <&> nonEmpty . fmap entityVal
-
- (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})
-<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: '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
- }).addTo(map);
-
- ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}");
-
- var marker = null;
-
- ws.onmessage = (msg) => {
- let json = JSON.parse(msg.data);
- if (marker === null) {
- marker = L.marker([json.lat, json.long]);
- marker.addTo(map);
- } else {
- marker.setLatLng([json.lat, json.long]);
- }
- map.setView([json.lat, json.long], 13);
- document.getElementById("status").innerText = "_{MsgLastPing}: "+json.lat+","+json.long+" ("+json.timestamp+")";
- }
-|]
-
-
-
-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!
-|]
-
-
-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
-
-getOnboardUnitMenuR :: Handler Html
-getOnboardUnitMenuR = do
- day <- liftIO getCurrentTime <&> utctDay
-
- tickets <-
- runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do
- firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ]
- pure (ticket, entityVal $ fromJust firstStop))
-
- defaultLayout $ do
- [whamlet|
- <h1>_{MsgOBU}
- <section>
- _{MsgChooseTrain}
- $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
- <hr>
- <a href="@{OnboardUnitR ticketId}">
- #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
- <section>
- <a href="@{OnboardTrackerR}">_{MsgStartTracking}
- |]
-
-getOnboardUnitR :: UUID -> Handler Html
-getOnboardUnitR ticketId = do
- Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case
- Nothing -> notFound
- Just ticket -> pure ticket
- defaultLayout $(whamletFile "site/obu.hamlet")
-
-getOnboardTrackerR :: Handler Html
-getOnboardTrackerR = do
- defaultLayout
- $( whamletFile "site/tracker.hamlet")
-
-
-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)
-
-
-
-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)
-
-
-mightbe :: Maybe Text -> Text
-mightbe (Just a) = a
-mightbe Nothing = ""
-
-
-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))
diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
new file mode 100644
index 0000000..8d744db
--- /dev/null
+++ b/lib/Server/Frontend.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Server.Frontend (Frontend(..), Handler) where
+
+import Server.Frontend.Gtfs
+import Server.Frontend.OnboardUnit
+import Server.Frontend.Routes
+import Server.Frontend.Tickets
+
+import Yesod
+import Yesod.Auth
+
+
+mkYesodDispatch "Frontend" resourcesFrontend
+
+
+getRootR :: Handler Html
+getRootR = redirect TicketsR
+
+
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..2d74338
--- /dev/null
+++ b/lib/Server/Frontend/Routes.hs
@@ -0,0 +1,145 @@
+{-# 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
+
+/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
+ UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
+ if uffdConfigEnable then maybeAuthId >>= \case
+ Just _ -> pure Authorized
+ Nothing -> pure AuthenticationRequired
+ else pure Authorized
+
+
+ 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
+ UffdConfig {..} -> if uffdConfigEnable
+ then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
+ else []
+ 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/Tickets.hs b/lib/Server/Frontend/Tickets.hs
new file mode 100644
index 0000000..43f24aa
--- /dev/null
+++ b/lib/Server/Frontend/Tickets.hs
@@ -0,0 +1,386 @@
+{-# 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.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)
+
+ 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
+
+ (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>
+ <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>
+<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 [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
+ anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
+ <&> nonEmpty . fmap entityVal
+
+ (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})
+<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: '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
+ }).addTo(map);
+
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}");
+
+ var marker = null;
+
+ ws.onmessage = (msg) => {
+ let json = JSON.parse(msg.data);
+ if (marker === null) {
+ marker = L.marker([json.lat, json.long]);
+ marker.addTo(map);
+ } else {
+ marker.setLatLng([json.lat, json.long]);
+ }
+ map.setView([json.lat, json.long], 13);
+ document.getElementById("status").innerText = "_{MsgLastPing}: "+json.lat+","+json.long+" ("+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
diff --git a/site/obu.hamlet b/site/obu.hamlet
deleted file mode 100644
index ed8017a..0000000
--- a/site/obu.hamlet
+++ /dev/null
@@ -1,132 +0,0 @@
-<h1>_{MsgOBU}
-
-<section>
- <h2>#{ticketTripName} _{Msgon} #{ticketDay}
- <strong>Token:</strong> <span id="token">
-
-<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">
-
-<section>
- <h2>Status
- <p id="status">_{MsgNone}
- <p id>_{MsgError}: <span id="error">
-
-
-<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;
-
- async function geoError(error) {
- document.getElementById("status").innerText = "error";
- alert(`_{MsgPermissionFailed}: \n${error.message}`);
- console.log(error);
- }
-
- 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/train/ping/ws");
- ws.onerror = wsError;
- ws.onclose = wsClose;
- ws.onmessage = wsMsg
- ws.onopen = (event) => initGeopos();
- }
-
- 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;
-
- ws.send(JSON.stringify({
- token: token,
- lat: geoloc.coords.latitude,
- long: geoloc.coords.longitude,
- timestamp: (new Date()).toISOString()
- }));
- counter += 1;
- document.getElementById("status").innerText = `sent ${counter} pings`;
- }
-
-
- async function main() {
- let trip = await (await fetch("/api/trip/#{ticketTripName}")).json();
- console.log("got trip info");
-
- token = await (await fetch("/api/train/register/#{UUID.toText ticketId}", {
- method: "POST",
- body: JSON.stringify({agent: "onboard-unit"}),
- headers: {"Content-Type": "application/json"}
- })).json();
-
-
- if (token.error) {
- alert("could not obtain token: \n" + token.msg);
- document.getElementById("status").innerText = "_{MsgTokenFailed}";
- } else {
- console.log("got token");
-
- document.getElementById("token").innerText = token;
-
- openWebsocket();
- }
- }
-
- main()
diff --git a/site/tracker.hamlet b/site/tracker.hamlet
deleted file mode 100644
index 2cc05e4..0000000
--- a/site/tracker.hamlet
+++ /dev/null
@@ -1,147 +0,0 @@
-<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/tracktrain.cabal b/tracktrain.cabal
index 5bf213f..542f986 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -102,7 +102,7 @@ library
exposed-modules: GTFS
, Server
, Server.GTFS_RT
- , Server.ControlRoom
+ , Server.Frontend
, PersistOrphans
, Persist
, Extrapolation
@@ -112,6 +112,13 @@ library
, Yesod.Auth.Uffd
, Yesod.Orphans
, MultiLangText
+ , Server.Base
+ , Server.Ingest
+ , Server.Subscribe
+ , Server.Frontend.Routes
+ , Server.Frontend.Tickets
+ , Server.Frontend.OnboardUnit
+ , Server.Frontend.Gtfs
default-language: GHC2021
default-extensions: OverloadedStrings
, ScopedTypeVariables
--
cgit v1.2.3