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 +++++++++++++++++++++++ 7 files changed, 784 insertions(+), 607 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 (limited to 'lib') 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 - - - - $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 -- cgit v1.2.3