1 files changed, 386 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
new file mode 100644
index 0000000..43f24aa
--- /dev/null
+++ b/lib/Server/Frontend/Tickets.hs
@@ -0,0 +1,386 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Tickets
+  ( getTicketsR
+  , postGtfsTicketImportR
+  , getTicketViewR
+  , getTicketMapViewR
+  , getDelAnnounceR
+  , postAnnounceR
+  , getTokenBlock
+  ) where
+
+import           Server.Frontend.Routes
+
+import           Config                   (ServerConfig (..), UffdConfig (..))
+import           Control.Monad            (forM, forM_, join)
+import           Control.Monad.Extra      (maybeM)
+import           Control.Monad.IO.Class   (MonadIO (liftIO))
+import           Data.Coerce              (coerce)
+import           Data.Function            (on, (&))
+import           Data.Functor             ((<&>))
+import           Data.List                (lookup, nubBy)
+import           Data.List.NonEmpty       (nonEmpty)
+import           Data.Map                 (Map)
+import qualified Data.Map                 as M
+import           Data.Maybe               (catMaybes, fromJust, isJust)
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time                (UTCTime (..), addDays,
+                                           getCurrentTime, utctDay)
+import           Data.Time.Calendar       (Day)
+import           Data.Time.Format.ISO8601 (iso8601Show)
+import           Data.UUID                (UUID)
+import qualified Data.UUID                as UUID
+import qualified Data.Vector              as V
+import           Extrapolation            (Extrapolator (..),
+                                           LinearExtrapolator (..))
+import           Fmt                      ((+|), (|+))
+import           GHC.Float                (int2Double)
+import qualified GTFS
+import           Numeric                  (showFFloat)
+import           Persist
+import           Server.Util              (Service, secondsNow)
+import           Text.Read                (readMaybe)
+import           Yesod
+import           Yesod.Auth
+import           Yesod.Auth.Uffd          (UffdUser (..), uffdClient)
+
+
+getTicketsR :: Handler Html
+getTicketsR = do
+  req <- getRequest
+  let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
+  mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
+
+  (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today ->
+    case maybeDay of
+      Just day -> (day, day == today)
+      Nothing  -> (today, True)
+
+  let prevday = (T.pack . iso8601Show . addDays (-1))  day
+  let nextday = (T.pack . iso8601Show . addDays 1) day
+  gtfs <- getYesod <&> getGtfs
+
+  -- TODO: tickets should have all trip information saved
+  tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketTripName ] >>= mapM (\ticket -> do
+    stops <- selectList [ StopTicket ==. entityKey ticket ] []
+    startStation <- getJust (stopStation $ entityVal $ head stops)
+    pure (ticket, startStation, fmap entityVal stops))
+
+  let trips = GTFS.tripsOnDay gtfs day
+
+  (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+  defaultLayout $ do
+    [whamlet|
+<h1> _{MsgTrainsOnDay (iso8601Show day)}
+$maybe name <- mdisplayname
+  <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
+<nav>
+  <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday}
+  $if isToday
+    _{Msgtoday}
+  $else
+    <a href="@{TicketsR}">_{Msgtoday}
+  <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
+<section>
+  <h2>_{MsgTickets}
+  <ol>
+   $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets
+    <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
+         : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
+   $if null tickets
+     <li style="text-align: center"><em>(_{MsgNone})</em>
+<section>
+  <h2>_{MsgAccordingToGtfs}
+  <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgImportTrips}
+   $if null trips
+     <li style="text-align: center"><em>(_{MsgNone})
+|]
+
+
+-- TODO: this function should probably look for duplicate imports
+postGtfsTicketImportR :: Day -> Handler Html
+postGtfsTicketImportR day = do
+  gtfs <- getYesod <&> getGtfs
+  let trips = GTFS.tripsOnDay gtfs day
+  ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+  case result of
+    FormSuccess selected -> do
+      now <- liftIO getCurrentTime
+
+      shapeMap <- selected
+        <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape))
+        & nubBy ((==) `on` fst)
+        & mapM (\(shapeId, shape) -> runDB $ do
+           key <- insert Shape
+           insertMany
+             $ shape
+             & GTFS.shapePoints
+             & V.indexed
+             & V.toList
+             <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key
+           pure (shapeId, key))
+        <&> M.fromList
+
+      stationMap <- selected
+        <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation))
+        & concat
+        & nubBy ((==) `on` GTFS.stationId)
+        & mapM (\GTFS.Station{..} -> runDB $ do
+            maybeExists <- selectFirst [ StationShortName ==. stationId ] []
+            case maybeExists of
+              Nothing -> do
+                key <- insert Station
+                  { stationGeopos = Geopos (stationLat, stationLon)
+                  , stationShortName = stationId , stationName }
+                pure (stationId, key)
+              Just (Entity key _) -> pure (stationId, key))
+        <&> M.fromList
+
+      selected
+        <&> (\(trip@GTFS.Trip{..}, day) ->
+            let
+              ticket = Ticket
+                   { ticketTripName = tripTripId, ticketDay = day, ticketImported = now
+                   , ticketSchedule_version = Nothing, ticketVehicle = Nothing
+                   , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip
+                   , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)}
+              stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop
+                   { stopTicket = ticketId
+                   , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap)
+                   , stopArrival, stopDeparture, stopSequence}
+            in (ticket, stops))
+        & unzip
+        & \(tickets, stops) -> runDB $ do
+            ticketIds <- insertMany tickets
+            forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) ->
+              insertMany (fmap (\s -> s ticketId) unfinishedStops)
+
+      redirect (TicketsR, [("day", T.pack (iso8601Show day))])
+
+    FormFailure _ -> defaultLayout [whamlet|
+<section>
+  <h2>_{MsgAccordingToGtfs}
+  <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+  let ticketKey = TicketKey ticketId
+  Ticket{..} <- runDB $ get ticketKey
+     >>= \case {Nothing -> notFound; Just a -> pure a}
+
+  stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
+    station <- getJust (stopStation (entityVal stop))
+    pure (entityVal stop, station))
+
+  anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+  joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+    <&> fmap (trackerTicketTracker . entityVal)
+  trackers <- runDB $ selectList
+    ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ])
+    [Asc TrackerExpires]
+  lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
+  anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
+    <&> nonEmpty . fmap entityVal
+
+  (widget, enctype) <- generateFormPost (announceForm ticketId)
+
+  nowSeconds <- secondsNow ticketDay
+  defaultLayout $ do
+    mr <- getMessageRender
+    setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
+    [whamlet|
+<h1>_{MsgTrip} #
+  <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName}
+  _{Msgon}
+  <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}
+<section>
+  <h2>_{MsgLive}
+  <p><strong>_{MsgLastPing}: </strong>
+    $maybe Entity _ TrainPing{..} <- lastPing
+      _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
+      (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
+    $nothing
+      <em>(_{MsgNoTrainPing})
+  <p><strong>_{MsgEstimatedDelay}</strong>:
+    $maybe history <- anchors
+      $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds
+        \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
+    $nothing
+      <em> (_{MsgNone})
+  <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a>
+<section>
+  <h2>_{MsgStops}
+  <ol>
+    $forall (Stop{..}, Station{..}) <- stops
+      <li value="#{stopSequence}"> #{stopArrival} #{stationName}
+        $maybe history <- anchors
+          $maybe delay <- guessDelay history (int2Double stopSequence)
+            \ (#{delay})
+<section>
+  <h2>_{MsgAnnouncements}
+  <ul>
+    $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
+      <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">_{Msgdelete}</a>
+    $if null anns
+      <li><em>(_{MsgNone})</em>
+  <h3>_{MsgNewAnnouncement}
+  <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgSubmit}
+<section>
+  <h2>_{MsgTokens}
+  <table>
+    <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
+    $if null trackers
+      <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
+    $forall Entity (TrackerKey key) Tracker{..} <- trackers
+      <tr :trackerBlocked:.blocked>
+        <td title="#{trackerAgent}">#{trackerAgent}
+        <td title="#{key}">#{key}
+        <td title="#{trackerExpires}">#{trackerExpires}
+        $if trackerBlocked
+          <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
+        $else
+          <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
+|]
+          where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history
+                guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
+
+
+getTicketMapViewR :: UUID -> Handler Html
+getTicketMapViewR ticketId = do
+  Ticket{..} <- runDB $ get (TicketKey ticketId)
+    >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
+
+  stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do
+    station <- getJust (stopStation (entityVal stop))
+    pure (entityVal stop, station))
+
+  (widget, enctype) <- generateFormPost (announceForm ticketId)
+
+  defaultLayout [whamlet|
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a>
+<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
+     integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
+     crossorigin=""/>
+<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js"
+     integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM="
+     crossorigin=""></script>
+<div id="map">
+<p id="status">
+<script>
+  let map = L.map('map');
+
+  L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', {
+      attribution: '&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