{-# 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