restructure: split web frontend into several modules

1 files changed, 0 insertions, 605 deletions

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: '&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+")";
-  }
-|]
-
-
-
-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))