diff options
author | stuebinm | 2024-05-08 23:34:43 +0200 |
---|---|---|
committer | stuebinm | 2024-05-09 01:31:26 +0200 |
commit | dc519ae889ab40fe1723cd601c3e79b73bdd2f51 (patch) | |
tree | 969bd8472ca40ebdd07eee46fc8c8506d1355f94 /lib/Server/Frontend/Tickets.hs | |
parent | ad8a09cafa519a15a22cafbfd2fa289538edc73d (diff) |
restructure: split web frontend into several modules
Diffstat (limited to 'lib/Server/Frontend/Tickets.hs')
-rw-r--r-- | lib/Server/Frontend/Tickets.hs | 386 |
1 files changed, 386 insertions, 0 deletions
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 |