{-# 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         #-}
{-# LANGUAGE ViewPatterns          #-}

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

import           Control.Monad            (forM_)
import           Control.Monad.Extra      (maybeM)
import           Control.Monad.IO.Class   (MonadIO (liftIO))
import qualified Data.ByteString.Char8    as C8
import           Data.Functor             ((<&>))
import           Data.List                (lookup)
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                (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.Generics             (Generic)
import           Persist                  (AmendmentStatus, Announcement (..),
                                           EntityField (..), Key (..),
                                           ScheduleAmendment (ScheduleAmendment),
                                           runSql)
import           Server.Util              (Service)
import           Text.Blaze.Html          (ToMarkup (..))
import           Text.ProtocolBuffers     (Default (defaultValue))
import           Text.Read                (readMaybe)
import           Yesod
import           Yesod.Form

import           GTFS


data ControlRoom = ControlRoom
  { getBaseurl :: Text
  , getGtfs    :: GTFS
  , getPool    :: Pool SqlBackend
  }

mkMessage "ControlRoom" "messages" "en"

mkYesod "ControlRoom" [parseRoutes|
/ RootR GET
/trains TrainsR GET
/train/id/#TripID/#Day TrainViewR GET
/train/announce/#TripID/#Day AnnounceR POST
/train/del-announce/#UUID DelAnnounceR GET
/trips TripsViewR GET
/trip/#TripID TripViewR GET
|]

instance Yesod ControlRoom where
  approot = ApprootMaster (\cr -> getBaseurl cr)

instance RenderMessage ControlRoom FormMessage where
  renderMessage _ _ = defaultFormMessage

-- which backend we're using and how to run an action.
instance YesodPersist ControlRoom where
  type YesodPersistBackend ControlRoom = SqlBackend
  runDB action = do
    pool <- getYesod <&> getPool
    runSqlPool action pool



getRootR :: Handler Html
getRootR = redirect (TrainsR)

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

  day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
  gtfs <- getYesod <&> getGtfs
  let trips = tripsOnDay gtfs day
  defaultLayout [whamlet|
<h1>Trains on #{iso8601Show day}
<ol>
  $forall Trip{..} <- trips
    <li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</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 ] []
      defaultLayout [whamlet|
<h1><a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{iso8601Show day}</a>
<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
<h2>_{MsgStops}
<ol>
  $forall Stop{..} <- tripStops
    <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}

<h2>Vehicle Position
<div> Todo!
|]


getTripsViewR :: Handler Html
getTripsViewR = do
  GTFS{..} <- getYesod <&> getGtfs
  defaultLayout [whamlet|
<h1>List of Trips
<ul>
  $forall Trip{..} <- trips
    <li><a href="@{TripViewR tripTripID}">#{tripTripID}</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{..} -> defaultLayout [whamlet|
<h1>Trip #{tripTripID}
<h2>Stops
<ol>
  $forall Stop{..} <- tripStops
    <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
<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)

instance ToMarkup Time where
  toMarkup time =
    toMarkup (show time)

data TrainAnnounceF = TrainAnnounceF
  { taHeader  :: Text
  , taMsg     :: Text
  , taLogTime :: Bool
  } deriving (Show)



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