{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}

module Server.Frontend.Tickets
  ( getTicketsR
  , postGtfsTicketImportR
  , getTicketViewR
  , getTicketMapViewR
  , getDelAnnounceR
  , postAnnounceR
  , getTrackerIdBlock
  ) 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.Frontend.SpaceTime (mkSpaceTimeDiagram,
                                            mkSpaceTimeDiagramHandler)
import           Server.Frontend.Ticker    (tickerWidget)
import           Server.Util               (Service, secondsNow)
import           Text.Read                 (readMaybe)
import           Yesod hiding ((==.), (||.), delete, update, (=.))
import qualified Yesod
import           Yesod.Auth
import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)

import Database.Esqueleto.Experimental hiding ((<&>), on) -- , on, delete, update, (=.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Experimental ((^.), (:&)(..), where_, orderBy, asc, associateJoin)

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)

  maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay Yesod.==. day ]

  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 $ E.select do
      ((ticket :& stop) :& station) <- E.from $
        (E.table @Ticket `E.InnerJoin` E.table @Stop
                          `E.on` \(ticket :& stop) -> ticket ^. TicketId E.==. stop E.^. StopTicket)
        `E.InnerJoin` E.table @Station `E.on` \((_ :& stop) :& station) -> stop E.^. StopStation E.==. station ^. StationId
      where_ (ticket ^. TicketDay E.==. (E.val day))
      orderBy [asc (ticket ^. TicketTripName)]
      pure (ticket, (stop, station))
    & fmap associateJoin

  let trips = GTFS.tripsOnDay gtfs day

  tickerAnnounceWidget <- tickerWidget

  (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>
  ^{tickerAnnounceWidget}
<section>
  <h2>_{MsgTickets}
  <ol>
   $forall (TicketKey ticketId, (Ticket{..}, stops)) <- M.toList tickets
    <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
         : _{Msgdep} #{stopDeparture (entityVal (fst (head stops)))} #{stationName (entityVal (snd (head stops)))} → #{ticketHeadsign}
   $if null tickets
     <li style="text-align: center"><em>(_{MsgNone})</em>
$maybe spaceTime <- maybeSpaceTime
  <section>
    ^{spaceTime}
<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 $ E.selectOne do
              station <- E.from (E.table @Station)
              where_ (station ^. StationShortName E.==. E.val stationId)
              pure station
            >>= \case
              Nothing -> do
                key <- insert Station
                  { stationGeopos = Geopos (stationLat, stationLon)
                  , stationShortName = stationId , stationName }
                pure (stationId, key)
              Just (Entity key _) -> pure (stationId, key))
        & fmap 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 $ select do
      (stop :& station) <- from $ table @Stop `innerJoin` table @Station
                                `E.on` \(stop :& station) -> stop ^. StopStation ==. station ^. StationId
      where_ (stop ^. StopTicket ==. val ticketKey)
      pure (stop, station)
     -- & fmap associateJoin
  -- stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
  --   station <- getJust (stopStation (entityVal stop))
  --   pure (entityVal stop, station))

  anns <- runDB $ select do
    ann <- from (table @Announcement)
    where_ (ann ^. AnnouncementTicket ==. val ticketKey)
    pure ann

  -- anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []

  trackers <- runDB $ select do
    (tt :& tracker) <- from $
       table @TrackerTicket `innerJoin` table @Tracker
       `E.on` \(tt :& tracker) -> tracker ^. TrackerId ==. tt ^. TrackerTicketTracker
    where_ (tt ^. TrackerTicketTicket ==. val ticketKey
           ||. tracker ^. TrackerCurrentTicket ==. val (Just ticketKey))
    pure tracker

  lastPing <- runDB $ selectOne do
    trainping <- from $ table @Ping
    where_ (trainping ^. PingTicket ==. val (Just (coerce ticketId)))
    orderBy [desc (trainping ^. PingTimestamp)]
    pure trainping

  anchors <- runDB $ select do
      anchor <- from $ table @TrainAnchor
      where_ (anchor ^. TrainAnchorTicket ==. val ticketKey)
      pure anchor
    <&> nonEmpty . fmap entityVal
  -- joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
  --   <&> fmap (trackerTicketTracker . entityVal)
  -- trackers <- runDB $ selectList
  --   ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ])
  --   [Asc TrackerExpires]
  -- lastPing <- runDB $ selectFirst [ PingTicket ==. coerce ticketId ] [Desc PingTimestamp]
  -- anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
  --   <&> nonEmpty . fmap entityVal

  spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId Yesod.==. coerce ticketId ]

  (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 _ Ping{..} <- lastPing
      _{MsgPing (latitude pingGeopos) (longitude pingGeopos) pingTimestamp}
      (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
    $nothing
      <em>(_{MsgNoPing})
  <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 (Entity _ Stop{..}, Entity _ Station{..}) <- stops
      <li value="#{stopSequence}"> #{stopArrival} #{stationName}
        $maybe history <- anchors
          $maybe delay <- guessDelay history (int2Double stopSequence)
            \ (#{delay})
$maybe spaceTime <- spaceTimeMaybe
  <section>
    ^{spaceTime}
<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>_{MsgTrackerIds}
  <table>
    <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgTrackerId}</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="_{MsgUnblockTrackerId}"><a href="@?{(TrackerIdBlock (TrackerKey key), [("unblock", "true")])}">_{MsgUnblockTrackerId}</a>
        $else
          <td title="_{MsgBlockTrackerId}"><a href="@{TrackerIdBlock (TrackerKey key)}">_{MsgBlockTrackerId}</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 $ E.select do
  --     (stop :& station) <- E.from $
  --       E.table @Stop `E.InnerJoin` E.table @Station
  --       `E.on` \(stop :& station) -> stop ^. StopStation E.==. station E.^. StationId
  --     where_ (stop ^. StopTicket E.==. (E.val (TicketKey ticketId)))
  --     pure (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/ticket/subscribe/#{UUID.toText ticketId}");

  var marker = null;

  ws.onmessage = (msg) => {
    let json = JSON.parse(msg.data);
    console.log(json)
    if (marker === null) {
      marker = L.marker(json.geopos);
      marker.addTo(map);
    } else {
      marker.setLatLng(json.geopos);
    }
    map.setView(json.geopos, 13);
    document.getElementById("status").innerText = "_{MsgLastPing}: "+json.geopos[0]+","+json.geopos[1]+" ("+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 do
      ann <- from (table @Announcement)
      where_ (ann ^. AnnouncementId ==. val (AnnouncementKey uuid))
    pure a
  case ann of
    Nothing -> notFound
    Just Announcement{..} ->
      let (TicketKey ticketId) = announcementTicket
      in redirect (TicketViewR ticketId)

getTrackerIdBlock :: TrackerId -> Handler Html
getTrackerIdBlock trackerId = do
  YesodRequest{..} <- getRequest
  let blocked = lookup "unblock" reqGetParams /= Just "true"
  maybe <- runDB do
    update \tracker -> do
      set tracker [TrackerBlocked =. val blocked]
      where_ (tracker ^. TrackerId ==. val trackerId)
    -- Yesod.update (TrackerKey trackerId) [ TrackerBlocked Yesod.=. blocked ]
    get trackerId
  case maybe of
    Just r@Tracker{..} -> do
      liftIO $ print r
      redirect $ case trackerCurrentTicket of
        Just ticket -> TicketViewR (coerce ticket)
        Nothing     -> RootR
    Nothing -> notFound