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

module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where

import           Control.Monad               (unless, when)
import           Control.Monad.IO.Class      (MonadIO (liftIO))
import qualified Data.ByteString.Char8       as C8
import qualified Data.Map                    as M
import           Data.Swagger                (ToSchema (..))
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import           Lucid                       (Html, HtmlT, ToHtml (toHtml), a_,
                                              action_, class_, div_, em_, for_,
                                              form_, h1_, h2_, h3_, href_, id_,
                                              input_, label_, li_, main_,
                                              method_, name_, ol_, placeholder_,
                                              type_, ul_, value_)
import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
                                              Get, Handler, JSON,
                                              NoContent (..), PlainText, Post,
                                              Proxy (Proxy), QueryParam,
                                              ReqBody, ServerError, err302,
                                              err404, errHeaders, throwError,
                                              type (:<|>) (..), type (:>))
import           Servant.HTML.Lucid          (HTML)
import           Web.FormUrlEncoded          (ToForm)
import           Web.Internal.FormUrlEncoded (Form)

import           Control.Monad               (forM_)
import           Control.Monad.Extra         (maybeM, whenM)
import           Data.Functor                ((<&>))
import           Data.Map                    (Map)
import           Data.Pool                   (Pool)
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           Database.Persist            (Entity (..), delete, entityVal,
                                              get, insert, selectList, (==.))
import           Database.Persist.Sql        (SqlBackend)
import           GHC.Generics                (Generic)
import           Lucid.Forms                 (ToHtmlForm (..),
                                              ToHtmlFormInput (..), formAction)
import           Persist                     (Announcement (..),
                                              EntityField (..), Key (..),
                                              runSql)
import           Server.Util                 (Service, redirect)
import           Text.ProtocolBuffers        (Default (defaultValue))
import           Web.FormUrlEncoded          (FromForm)

import           GTFS

data TrainView = TrainView
  { tvDay           :: Day
  , tvTrip          :: Trip Deep Deep
  , tvAnnouncements :: [Entity Announcement]
  , tvRunning       :: Bool
  } deriving Show

type ControlRoomAPI =
  "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
  :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
  :<|> ControlRoomCranks

-- | train infra seems to involve turning lots of cranks, so here have some!
type ControlRoomCranks =
  "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
  :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent
  :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
  :<|> "train" :> "date" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
  :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
  :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
  :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI

data TrainAnnounceF = TrainAnnounceF
  { taHeader  :: Text
  , taMsg     :: Text
  , taLogTime :: Maybe Bool
  } deriving (Generic, ToHtmlForm, FromForm)


controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
  :<|> controlRoomCranks dbpool
  where handleTrip trip day = case M.lookup trip trips of
          Just res -> do
            as <- runSql dbpool
              $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
            pure (TrainView day res as True) -- TODO: can't just assume it runs that day …
          Nothing  -> throwError err404
        handleTimetable maybeDay = do
          -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
          day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
          pure $ (day, tripsOnDay gtfs day)

controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> undefined
  where handleAnnounce tripID day TrainAnnounceF{..} = do
          now <- liftIO $ getCurrentTime
          AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
            { announcementTrip = tripID
            , announcementMessage = taMsg
            , announcementHeader = taHeader
            , announcementDay = day
            , announcementUrl = Nothing
            , announcementAnnouncedAt =
              fmap (const now) taLogTime
            }
          redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day))
        handleAnnounceDel uuid = do
          ann <- runSql dbpool $ do
            a <- get (AnnouncementKey uuid)
            delete (AnnouncementKey uuid)
            pure a
          case ann of
            Nothing -> throwError err404
            Just Announcement{..} ->
              redirect ("/cr/train/"<>C8.pack (T.unpack announcementTrip)<>"/"<>C8.pack (iso8601Show announcementDay))


instance ToHtmlFormInput CalendarExceptionType
instance ToHtmlForm CalendarDate


instance ToHtml TrainView  where
  toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do
    unless running $ do
      div_ [class_ "warning"] "Warning: Trip not running on this day!"

    h2_ "Announcements"
    ul_ $ do
      unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do
        li_ $ do
          em_ (toHtml announcementHeader); ": "; toHtml announcementMessage
          " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete"
      li_ $ do
        "Add Announcement:"
        toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
          (Proxy @TrainAnnounceF)

    h2_ "Stops"
    ol_ $ forM_ tripStops $ \Stop{..} -> do
      div_ (toHtml (stationName stopStation))

    h2_ "Vehicle Position"
    div_ "todo!"


instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
  toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do
    ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
      a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID)
    when (null trips) $ do
      em_ "(none)"
    where shownDay = T.pack (iso8601Show day)

-- | control room page
crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
crPage title content = do
  h1_ (toHtml title)
  main_ content