{-# 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.IO.Class      (MonadIO (liftIO))
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_, div_, for_, form_, h1_,
                                              h2_, href_, id_, input_, label_,
                                              li_, main_, method_, name_, ol_,
                                              placeholder_, type_, value_)
import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
                                              Get, JSON, NoContent, PlainText,
                                              Post, Proxy (Proxy), QueryParam,
                                              ReqBody, err404, err302,
                                              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           Database.Persist            (insert)
import           Database.Persist.Sql        (SqlBackend)
import           GHC.Generics                (Generic)
import           Lucid.Forms                 (ToHtmlForm (..),
                                              ToHtmlFormInput (..), formAction)
import           Persist                     (Announcement (..), Key (..),
                                              runSql)
import           Server.Util                 (Service)
import           Text.ProtocolBuffers        (Default (defaultValue))
import           Web.FormUrlEncoded          (FromForm)

import           GTFS

type ControlRoomAPI =
  "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
  :<|> "trip" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] (Day, Trip Deep Deep)
  :<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text
  :<|> 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" :> "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
  { taMsg     :: Text
  , taHeader  :: Text
  , taLogTime :: Maybe Bool
  } deriving (Generic, ToHtmlForm, FromForm)

controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
  :<|> (\text -> do
           liftIO $ putStrLn (show text)
           pure "hello"
       )
  :<|> controlRoomCranks dbpool
  where handleTrip trip day = case M.lookup trip trips of
          Just res -> pure (day, res) -- 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 :<|> 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
            }
          throwError $ err302 { errHeaders = [("Location", "/cr/main")] }


instance ToHtmlFormInput CalendarExceptionType
instance ToHtmlForm CalendarDate


instance ToHtml (Day, Trip Deep Deep) where
  toHtml (day, Trip{..}) = crPage tripTripID $ do
    h2_ "Stops"
    ol_ $ forM_ tripStops $ \Stop{..} -> do
      div_ (toHtml (stationName stopStation))
    toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
      (Proxy @TrainAnnounceF)

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

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