path: root/lib/Server/ControlRoom.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module Server.ControlRoom (ControlRoom(..)) where

import           Control.Monad             (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.Functor              ((<&>))
import           Data.List                 (lookup)
import           Data.List.NonEmpty        (nonEmpty)
import           Data.Map                  (Map)
import qualified Data.Map                  as M
import           Data.Pool                 (Pool)
import           Data.Text                 (Text)
import qualified Data.Text                 as T
import           Data.Time                 (UTCTime (..), 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           Fmt                       ((+|), (|+))
import           GHC.Float                 (int2Double)
import           GHC.Generics              (Generic)
import           Server.Util               (Service, secondsNow)
import           Text.Blaze.Html           (ToMarkup (..))
import           Text.Blaze.Internal       (MarkupM (Empty))
import           Text.ProtocolBuffers      (Default (defaultValue))
import           Text.Read                 (readMaybe)
import           Text.Shakespeare.Text
import           Yesod
import           Yesod.Auth
import           Yesod.Auth.OAuth2.Prelude
import           Yesod.Form

import           Config                    (ServerConfig (..), UffdConfig (..))
import           Extrapolation             (Extrapolator (..),
                                            LinearExtrapolator (..))
import           GTFS
import           Numeric                   (showFFloat)
import           Persist
import           Yesod.Auth.OpenId         (IdentifierType (..), authOpenId)
import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)


data ControlRoom = ControlRoom
  { getGtfs     :: GTFS
  , getPool     :: Pool SqlBackend
  , getSettings :: ServerConfig
  }

mkMessage "ControlRoom" "messages" "en"

mkYesod "ControlRoom" [parseRoutes|
/ RootR GET
/auth AuthR Auth getAuth
/trains TrainsR GET
/train/id/#TripID/#Day TrainViewR GET
/train/map/#TripID/#Day TrainMapViewR GET
/train/announce/#TripID/#Day AnnounceR POST
/train/del-announce/#UUID DelAnnounceR GET
/token/block/#Token TokenBlock GET
/trips TripsViewR GET
/trip/#TripID TripViewR GET
/obu OnboardUnitMenuR GET
/obu/#TripID/#Day OnboardUnitR 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 (AuthR _) _ = pure Authorized
  isAuthorized _ _ = do
    UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin
    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}
            <style>
              section {
                border: 1px solid black;
                padding: 1rem;
                margin: 2rem;
                padding-top: 0;
              }
              body {
                max-width: 50rem;
                margin: auto;
                }
             form {
               width:100%;
               display: grid;
               gap: 1rem;
             }
             label {
               grid-column: 1;
             }
             form div {
               display: grid;
               grid-template-columns: 50% 50%;
               width:100%;
             }
             input {
               grid-column: 2;
             }
             .blocked {
               background-color: red;
             }
             #map {
               width: 100%;
               height: 50vh;
             }
          <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) $ \(key, val) ->
      setSession key val
    -- 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 TrainsR

getTrainsR :: Handler Html
getTrainsR = do
  req <- getRequest
  let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
  mdisplayname <- maybeAuthId <&> fmap uffdDisplayName

  day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
  gtfs <- getYesod <&> getGtfs
  let trips = tripsOnDay gtfs day
  defaultLayout $ do
    [whamlet|
<h1>Trains on #{day}
$maybe name <- mdisplayname
  <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
<section><ol>
  $forall trip@Trip{..} <- trips
    <li><a href="@{TrainViewR tripTripID day}">#{tripName trip}</a>
        : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
|]

getTrainViewR :: TripID -> Day -> Handler Html
getTrainViewR trip day = do
  GTFS{..} <- getYesod <&> getGtfs
  (widget, enctype) <- generateFormPost (announceForm day trip)
  case M.lookup trip trips of
    Nothing -> notFound
    Just res@Trip{..} -> do
      anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
      tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
      lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
      anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
        <&> nonEmpty . fmap entityVal
      nowSeconds <- secondsNow day
      defaultLayout $ do
        mr <- getMessageRender
        setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
        [whamlet|
<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
<section>
  <h2>_{MsgLive}
  <p><strong>_{MsgLastPing}: </strong>
    $maybe Entity _ TrainPing{..} <- lastPing
      _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
      (<a href="/api/debug/pings/#{trip}/#{day}">_{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="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
<section>
  <h2>_{MsgStops}
  <ol>
    $forall Stop{..} <- tripStops
      <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation}
        $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}">delete</a>
    $if null anns
      <li><em>(_{MsgNone})</em>
  <h3>_{MsgNewAnnouncement}
  <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
    ^{widget}
    <button>Submit
<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 tokens
      <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
    $forall Entity (RunningKey key) Running{..} <- tokens
      <tr :runningBlocked:.blocked>
        <td title="#{runningAgent}">#{runningAgent}
        <td title="#{key}">#{key}
        <td title="#{runningExpires}">#{runningExpires}
        $if runningBlocked
          <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


getTrainMapViewR :: TripID -> Day -> Handler Html
getTrainMapViewR tripId day = do
  GTFS{..} <- getYesod <&> getGtfs
  (widget, enctype) <- generateFormPost (announceForm day tripId)
  case M.lookup tripId trips of
    Nothing -> notFound
    Just res@Trip{..} -> do defaultLayout $ [whamlet|
<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</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/#{tripTripID}/#{day}");

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



getTripsViewR :: Handler Html
getTripsViewR = do
  GTFS{..} <- getYesod <&> getGtfs
  defaultLayout $ do
    setTitle "List of Trips"
    [whamlet|
<h1>List of Trips
<section><ul>
  $forall trip@Trip{..} <- trips
    <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a>
      : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
|]


getTripViewR :: TripID -> Handler Html
getTripViewR tripId = do
  GTFS{..} <- getYesod <&> getGtfs
  case M.lookup tripId trips of
    Nothing -> notFound
    Just trip@Trip{..} -> defaultLayout [whamlet|
<h1>Trip #{tripName trip}
<section>
  <h2>Info
  <p><strong>_{MsgtripId}:</strong> #{tripTripID}
  <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
  <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
<section>
  <h2>Stops
  <ol>
    $forall Stop{..} <- tripStops
      <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
<section>
  <h2>Dates
  <ul>
    TODO!
|]


postAnnounceR :: TripID -> Day -> Handler Html
postAnnounceR trip day = do
    ((result, widget), enctype) <- runFormPost (announceForm day trip)
    case result of
        FormSuccess ann -> do
          runDB $ insert ann
          redirect (TrainViewR trip day)
        _ -> defaultLayout
            [whamlet|
                <p>Invalid input, let's try again.
                <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
                    ^{widget}
                    <button>Submit
            |]

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{..} ->
      redirect (TrainViewR announcementTrip announcementDay)

getTokenBlock :: Token -> Handler Html
getTokenBlock token = do
  YesodRequest{..} <- getRequest
  let blocked = lookup "unblock" reqGetParams /= Just "true"
  maybe <- runDB $ do
    update (RunningKey token) [ RunningBlocked =. blocked ]
    get (RunningKey token)
  case maybe of
    Just r@Running{..} -> do
      liftIO $ print r
      redirect (TrainViewR runningTrip runningDay)
    Nothing -> notFound

getOnboardUnitMenuR :: Handler Html
getOnboardUnitMenuR = do
  day <- liftIO getCurrentTime <&> utctDay
  gtfs <- getYesod <&> getGtfs
  let trips = tripsOnDay gtfs day
  defaultLayout $ do
    [whamlet|
<h1>_{MsgOBU}
<section>
  _{MsgChooseTrain}
  $forall Trip{..} <- trips
    <hr>
    <a href="@{OnboardUnitR tripTripID day}">
      #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
|]

getOnboardUnitR :: TripID -> Day -> Handler Html
getOnboardUnitR tripId day =
  defaultLayout $(whamletFile "site/obu.hamlet")

announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
announceForm day tripId = renderDivs $ Announcement
  <$> pure tripId
  <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
  <*> areq textField (fieldSettingsLabel MsgText) Nothing
  <*> pure day
  <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
  <*> lift (liftIO getCurrentTime <&> Just)

mightbe :: Maybe Text -> Text
mightbe (Just a) = a
mightbe Nothing  = ""

--- some orphans to make hamlet easier to deal with
instance ToMarkup Time where
  toMarkup time =
    toMarkup (show time)

instance ToMarkup Day where
  toMarkup day = toMarkup (iso8601Show day)

instance ToMessage UTCTime where
  toMessage = formatW3

instance ToMessage Token where
  toMessage (Token uuid) = UUID.toText uuid

instance ToMarkup UTCTime where
  toMarkup = toMarkup . formatW3

instance ToMarkup Token where
  toMarkup (Token uuid) = toMarkup (UUID.toText uuid)

instance ToMessage Double where
  toMessage = T.pack . show

instance ToMarkup Seconds where
  toMarkup (Seconds s) =
    if s > 0 then toMarkup ("+"+|s `div` 60|+"" :: Text)
    else toMarkup (s `div` 60)