restructure: split web frontend into several modules

4 files changed, 762 insertions, 0 deletions

diff --git a/lib/Server/Frontend/Gtfs.hs b/lib/Server/Frontend/Gtfs.hs
new file mode 100644
index 0000000..bc21ab7
--- /dev/null
+++ b/lib/Server/Frontend/Gtfs.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Gtfs (getGtfsTripViewR, getGtfsTripsViewR) where
+
+import           Server.Frontend.Routes
+
+import           Data.Functor           ((<&>))
+import qualified Data.Map               as M
+import           Data.Text              (Text)
+import qualified Data.Vector            as V
+import qualified GTFS
+import           Text.Blaze.Html        (Html)
+import           Yesod
+
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
+  defaultLayout $ do
+    setTitle "List of Trips"
+    [whamlet|
+<h1>List of Trips
+<section><ul>
+  $forall trip@GTFS.Trip{..} <- trips
+    <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
+      : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
+|]
+
+
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
+  case M.lookup tripId trips of
+    Nothing -> notFound
+    Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
+<section>
+  <h2>_{MsgInfo}
+  <p><strong>_{MsgtripId}:</strong> #{tripTripId}
+  <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
+  <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
+<section>
+  <h2>_{MsgStops}
+  <ol>
+    $forall GTFS.Stop{..} <- tripStops
+      <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
+<section>
+  <h2>Dates
+  <ul>
+    TODO!
+|]
+
+mightbe :: Maybe Text -> Text
+mightbe (Just a) = a
+mightbe Nothing  = ""
diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs
new file mode 100644
index 0000000..6a8fe6e
--- /dev/null
+++ b/lib/Server/Frontend/OnboardUnit.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.OnboardUnit (getOnboardTrackerR) where
+
+import           Server.Frontend.Routes
+
+import           Data.Functor           ((<&>))
+import qualified Data.Map               as M
+import           Data.Maybe             (fromJust)
+import           Data.Text              (Text)
+import           Data.Time              (UTCTime (..), getCurrentTime)
+import           Data.UUID              (UUID)
+import qualified Data.UUID              as UUID
+import qualified Data.Vector            as V
+import qualified GTFS
+import           Persist                (EntityField (..), Key (..), Stop (..),
+                                         Ticket (..))
+import           Text.Blaze.Html        (Html)
+import           Yesod
+
+
+getOnboardTrackerR :: Handler Html
+getOnboardTrackerR = do defaultLayout [whamlet|
+  <h1>_{MsgOBU}
+
+  <section>
+    <h2>Tracker
+    <strong>Token:</strong> <span id="token">
+  <section>
+    <h2>Status
+    <p id="status">_{MsgNone}
+    <p id>_{MsgError}: <span id="error">
+  <section>
+    <h2>_{MsgLive}
+    <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
+    <p><strong>Accuracy: </strong><span id="acc">
+  <section>
+    <h2>_{MsgEstimated}
+    <p><strong>_{MsgDelay}</strong>: <span id="delay">
+    <p><strong>_{MsgSequence}</strong>: <span id="sequence">
+
+
+  <script>
+    var token = null;
+
+    let euclid = (a,b) => {
+      let x = a[0]-b[0];
+      let y = a[1]-b[1];
+      return x*x+y*y;
+    }
+
+    let minimalDist = (point, list, proj, norm) => {
+      return list.reduce (
+        (min, x) => {
+          let dist = norm(point, proj(x));
+          return dist < min[0] ? [dist,x] : min
+        },
+        [norm(point, proj(list[0])), list[0]]
+      )[1]
+    }
+
+    let counter = 0;
+    let ws;
+    let id;
+
+    function setStatus(msg) {
+      document.getElementById("status").innerText = msg
+    }
+
+    async function geoError(error) {
+      setStatus("error");
+      alert(`_{MsgPermissionFailed}: \n${error.message}`);
+      console.error(error);
+      main();
+    }
+
+    async function wsError(error) {
+      // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`);
+      console.log(error);
+      navigator.geolocation.clearWatch(id);
+    }
+
+    async function wsClose(error) {
+      console.log(error);
+      document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`;
+      navigator.geolocation.clearWatch(id);
+      setTimeout(openWebsocket, 1000);
+    }
+
+    function wsMsg(msg) {
+      let json = JSON.parse(msg.data);
+      console.log(json);
+      document.getElementById("delay").innerText =
+        `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
+      document.getElementById("sequence").innerText = json.sequence;
+    }
+
+
+    function initGeopos() {
+      document.getElementById("error").innerText = "";
+      id = navigator.geolocation.watchPosition(
+        geoPing,
+        geoError,
+        {enableHighAccuracy: true}
+      );
+    }
+
+
+    function openWebsocket () {
+      ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/tracker/ping/ws");
+      ws.onerror = wsError;
+      ws.onclose = wsClose;
+      ws.onmessage = wsMsg;
+      ws.onopen = (event) => {
+        setStatus("connected");
+      };
+    }
+
+    async function geoPing(geoloc) {
+      console.log("got position update " + counter);
+      document.getElementById("lat").innerText = geoloc.coords.latitude;
+      document.getElementById("long").innerText = geoloc.coords.longitude;
+      document.getElementById("acc").innerText = geoloc.coords.accuracy;
+
+      if (ws !== undefined && ws.readyState == 1) {
+          ws.send(JSON.stringify({
+              token: token,
+              geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ],
+              timestamp: (new Date()).toISOString()
+          }));
+          counter += 1;
+          setStatus(`sent ${counter} pings`);
+      } else {
+          setStatus(`websocket readystate ${ws.readyState}`);
+      }
+    }
+
+
+    async function main() {
+      initGeopos();
+
+      let urlparams = new URLSearchParams(window.location.search);
+
+      token = urlparams.get("token");
+
+        if (token === null) {
+          token = await (await fetch("/api/tracker/register/", {
+               method: "POST",
+               body: JSON.stringify({agent: "tracktrain-website"}),
+               headers: {"Content-Type": "application/json"}
+          })).json();
+
+          if (token.error) {
+              alert("could not obtain token: \n" + token.msg);
+              setStatus("_{MsgTokenFailed}");
+          } else {
+              console.log("got token");
+              window.location.search = `?token=${token}`;
+          }
+      }
+
+      console.log(token)
+
+      if (token !== null) {
+          document.getElementById("token").innerText = token;
+          openWebsocket();
+      }
+    }
+
+    main()
+  |]
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
new file mode 100644
index 0000000..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: '&copy; <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