{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TupleSections         #-}

module Server.GTFS_RT (gtfsRealtimeServer) where

import           API                         (GtfsRealtimeAPI)
import           Control.Lens                ((&), (.~))
import           Control.Monad               (forM)
import           Control.Monad.Extra         (mapMaybeM)
import           Control.Monad.IO.Class      (MonadIO (..))
import           Data.Functor                ((<&>))
import           Data.List.NonEmpty          (NonEmpty, nonEmpty)
import qualified Data.Map                    as M
import           Data.Maybe                  (catMaybes, mapMaybe)
import           Data.Pool                   (Pool)
import           Data.ProtoLens              (defMessage)
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import           Data.Time.Calendar          (Day, toGregorian)
import           Data.Time.Clock             (UTCTime (utctDay), addUTCTime,
                                              getCurrentTime)
import           Data.Time.Clock.System      (SystemTime (systemSeconds),
                                              getSystemTime, utcToSystemTime)
import           Data.Time.Format.ISO8601    (iso8601Show)
import           Data.UUID                   (toASCIIBytes, toLazyASCIIBytes)
import qualified Data.UUID                   as UUID
import qualified Data.Vector                 as V
import           Database.Persist            (Entity (..),
                                              PersistQueryRead (selectFirst),
                                              selectList, (==.))
import           Database.Persist.Postgresql (SqlBackend)
import           Extrapolation               (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
                                              LinearExtrapolator (..))
import           GHC.Float                   (double2Float, int2Double)
import           GTFS                        (Depth (..), GTFS (..),
                                              Seconds (..), Stop (..),
                                              Trip (..), TripID,
                                              showTimeWithSeconds, stationId,
                                              toSeconds, toUTC, tripsOnDay)
import           Persist                     (Announcement (..),
                                              EntityField (..), Key (..),
                                              Running (..), Token (..),
                                              TrainAnchor (..), TrainPing (..),
                                              runSql)
import qualified Proto.GtfsRealtime          as RT
import qualified Proto.GtfsRealtime_Fields   as RT
import           Servant.API                 ((:<|>) (..))
import           Server.Util                 (Service, secondsNow)

-- | formats a day in the "stupid" format used by gtfs realtime
toStupidDate :: Day -> Text
toStupidDate date =
  pad 4 year <> pad 2 month <> pad 2 day
  where (year, month, day) = toGregorian date
        pad len num = T.pack $ if ndigits < len
          then replicate (len - ndigits) '0' <> show num
          else show num
          where ndigits = length (show num)

-- | basically unix timestamps, raw (because why not i guess)
toStupidTime :: Num i => UTCTime -> i
toStupidTime = fromIntegral . systemSeconds . utcToSystemTime

gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI
gtfsRealtimeServer gtfs@GTFS{..} dbpool =
  handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
  where
    handleServiceAlerts = runSql dbpool $ do
      announcements <- selectList [] []
      defFeedMessage (fmap mkAlert announcements)

      where
        mkAlert :: Entity Announcement -> RT.FeedEntity
        mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
              defMessage
              & RT.id .~ UUID.toText uuid
              & RT.alert .~ (defMessage
                  & RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
                  & RT.informedEntity .~ [ defMessage
                       & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
                    ]
                  & RT.maybe'url .~ fmap (monolingual "de") announcementUrl
                  & RT.headerText .~ monolingual "de" announcementHeader
                  & RT.descriptionText .~ monolingual "de" announcementMessage
               )

    handleTripUpdates = runSql dbpool $ do
      today <- liftIO $ getCurrentTime <&> utctDay
      nowSeconds <- secondsNow today
      let running = M.toList (tripsOnDay gtfs today)
      anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
        entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
        case nonEmpty (fmap entityVal entities) of
          Nothing      -> pure Nothing
          Just anchors -> pure $ Just (tripId, trip, anchors)

      defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors)
      where
        mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity
        mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) =
              let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds
                  stations = tripStops
                    <&> (\stop@Stop{..} -> (, stop)
                          <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence))
                  (lastAnchor, lastStop) = V.last (V.catMaybes stations)
                  stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
                    < nowSeconds + 5 * 60
              in if not stillRunning then Nothing else Just $ defMessage
                & RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today))
                & RT.tripUpdate .~ (defMessage
                    & RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops))
                    & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations)
                    & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
                    & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
                )
          where
            mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate
            mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage
              & RT.stopSequence .~ fromIntegral stopSequence
              & RT.stopId .~ stationId stopStation
              & RT.arrival .~ (defMessage
                  & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
                  & RT.time .~ toStupidTime (addUTCTime
                      (fromIntegral $ unSeconds trainAnchorDelay)
                      (toUTC stopArrival tzseries today))
                  & RT.uncertainty .~ 60
              )
              & RT.departure .~ (defMessage
                  & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
                  & RT.time .~ toStupidTime (addUTCTime
                      (fromIntegral $ unSeconds trainAnchorDelay)
                      (toUTC stopDeparture tzseries today))
                  & RT.uncertainty .~ 60
              )
              & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED

    handleVehiclePositions = runSql dbpool $ do
      (running :: [Entity Running]) <- selectList [] []
      pings <- forM running $ \(Entity key entity) -> do
        selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
      defFeedMessage (mkPosition <$> catMaybes pings)

      where
        mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
        mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
          & RT.id .~ T.pack (show key)
          & RT.vehicle .~ (defMessage
              & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
              & RT.maybe'vehicle .~ case runningVehicle of
                  Nothing -> Nothing
                  Just trainset -> Just $ defMessage
                    & RT.label .~ trainset
              & RT.position .~ (defMessage
                  & RT.latitude .~ double2Float trainPingLat
                  & RT.longitude .~ double2Float trainPingLong
              )
              -- TODO: should probably give currentStopSequence/stopId here as well
              & RT.timestamp .~ toStupidTime trainPingTimestamp
          )


monolingual :: Text -> Text -> RT.TranslatedString
monolingual code msg = defMessage & RT.translation .~ [
  defMessage
    & RT.text .~ msg
    & RT.language .~ code
  ]

defFeedMessage :: MonadIO m => [RT.FeedEntity] -> m RT.FeedMessage
defFeedMessage entities = do
  now <- liftIO getSystemTime <&> systemSeconds
  pure $ defMessage
   & RT.header .~ (defMessage
       & RT.gtfsRealtimeVersion .~ "2.0"
       & RT.incrementality .~ RT.FeedHeader'FULL_DATASET
       & RT.timestamp .~ fromIntegral now
   )
   & RT.entity .~ entities

defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
defTripDescriptor tripId day starttime = defMessage
  & RT.tripId .~ tripId
  & RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED
  & RT.maybe'startTime .~ starttime
  & RT.maybe'startDate .~ fmap toStupidDate day