{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeApplications  #-}

module Server.GTFS_RT (gtfsRealtimeServer) where

import           Prelude                                    hiding (id)

import           API                                        (GtfsRealtimeAPI)
import           Control.Monad                              (forM)
import           Control.Monad.IO.Class                     (MonadIO (..))
import           Data.ByteString.Lazy                       (fromStrict)
import           Data.Functor                               ((<&>))
import qualified Data.Map                                   as M
import           Data.Maybe                                 (catMaybes)
import           Data.Pool                                  (Pool)
import           Data.Sequence                              (Seq)
import qualified Data.Sequence                              as Seq
import           Data.Text                                  (Text)
import qualified Data.Text                                  as T
import           Data.Text.Encoding                         (encodeUtf8)
import           Data.Time.Calendar                         (Day, toGregorian)
import           Data.Time.Clock                            (UTCTime (utctDay),
                                                             getCurrentTime)
import           Data.Time.Clock.POSIX                      (getPOSIXTime)
import           Data.Time.Clock.System                     (SystemTime (systemSeconds),
                                                             getSystemTime,
                                                             utcToSystemTime)
import qualified Data.UUID                                  as UUID
import           Data.Word                                  (Word64)
import           Database.Persist                           (Entity (..),
                                                             PersistQueryRead (selectFirst),
                                                             selectList, (==.))
import           Database.Persist.Postgresql                (SqlBackend)
import           GHC.Float                                  (double2Float,
                                                             int2Double)
import           GTFS                                       (GTFS (..),
                                                             Seconds (..),
                                                             Stop (..),
                                                             Trip (..), TripID)
import           GTFS.Realtime.Alert                        as AL (Alert (..))
import           GTFS.Realtime.Alert.SeverityLevel          (SeverityLevel (WARNING))
import           GTFS.Realtime.EntitySelector               as ES (EntitySelector (..))
import           GTFS.Realtime.FeedEntity                   as FE (FeedEntity (..))
import           GTFS.Realtime.FeedHeader                   (FeedHeader (FeedHeader))
import           GTFS.Realtime.FeedHeader.Incrementality    (Incrementality (FULL_DATASET))
import           GTFS.Realtime.FeedMessage                  as FM (FeedMessage (..))
import           GTFS.Realtime.Position                     as POS (Position (..))
import           GTFS.Realtime.TimeRange                    (TimeRange (TimeRange))
import           GTFS.Realtime.TranslatedString             (TranslatedString (TranslatedString))
import           GTFS.Realtime.TranslatedString.Translation (Translation (Translation))
import           GTFS.Realtime.TripDescriptor               as TD (TripDescriptor (..))
import           GTFS.Realtime.TripUpdate                   as TU (TripUpdate (..))
import           GTFS.Realtime.TripUpdate.StopTimeEvent     as STE (StopTimeEvent (..))
import           GTFS.Realtime.TripUpdate.StopTimeUpdate    as STU (StopTimeUpdate (..))
import           GTFS.Realtime.VehicleDescriptor            as VD (VehicleDescriptor (..))
import           GTFS.Realtime.VehiclePosition              as VP (VehiclePosition (..))
import           Persist                                    (Announcement (..),
                                                             EntityField (..),
                                                             Key (..),
                                                             Running (..),
                                                             Token (..),
                                                             TrainAnchor (..),
                                                             TrainPing (..),
                                                             runSql)
import           Servant.API                                ((:<|>) (..))
import           Text.ProtocolBuffers                       (Utf8 (Utf8),
                                                             defaultValue)

import           Control.Monad.Extra                        (mapMaybeM)
import           Data.List.NonEmpty                         (nonEmpty)
import           Data.UUID                                  (toASCIIBytes,
                                                             toLazyASCIIBytes)
import qualified Data.Vector                                as V
import           Extrapolation                              (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
                                                             LinearExtrapolator)
import           GTFS                                       (Depth (..))
import           GTFS.Realtime.TripUpdate                   (TripUpdate (TripUpdate))
import           Server.Util                                (Service,
                                                             secondsNow)

uuidUtf8 :: UUID.UUID -> Utf8
uuidUtf8 = Utf8 . fromStrict . UUID.toASCIIBytes

toUtf8 :: Text -> Utf8
toUtf8 = Utf8 . fromStrict . encodeUtf8

-- | formats a day in the "stupid" format used by gtfs realtime
toStupidDate :: Day -> Utf8
toStupidDate date = toUtf8
  $ 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 :: UTCTime -> Word64
toStupidTime = fromIntegral . systemSeconds . utcToSystemTime

gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI
gtfsRealtimeServer gtfs@GTFS{..} dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
  where handleServiceAlerts = runSql dbpool $ do
            -- TODO filter: only select current & future days
            announcements <- selectList [] []
            dFeedMessage $ Seq.fromList $ fmap mkAlert announcements
            where mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
                    (dFeedEntity (uuidUtf8 uuid))
                    { alert = Just $ Alert
                      { active_period = [TimeRange Nothing Nothing defaultValue]
                        -- TODO: is this time range reasonable, needed, etc.?
                      , informed_entity =
                        [dEntitySelector
                          { ES.trip =
                            Just (dTripDescriptor announcementTrip (Just announcementDay))
                          }
                        ]
                      , cause = Nothing
                      , effect = Nothing
                      , url = fmap (lang "de" . toUtf8) announcementUrl
                      , header_text = Just $ lang "de" (toUtf8 announcementHeader)
                      , description_text = Just $ lang "de" (toUtf8 announcementMessage)
                      , tts_header_text = Nothing
                      , tts_description_text = Nothing
                      , severity_level = Nothing
                      , image = Nothing
                      , image_alternative_text = Nothing
                      , AL.ext'field = defaultValue
                      }
                    }


        handleTripUpdates = runSql dbpool $ do
          today <- liftIO $ getCurrentTime <&> utctDay
          nowSeconds <- secondsNow today
          running <- selectList [RunningDay ==. today] []
          anchors <- flip mapMaybeM running $ \r@(Entity key Running{..}) -> do
            entities <- selectList [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. today] []
            case nonEmpty (fmap entityVal entities) of
              Nothing -> pure Nothing
              Just anchors -> case M.lookup runningTrip trips of
                Nothing   -> pure Nothing
                Just trip -> pure (Just (r, trip, anchors))

          dFeedMessage $ Seq.fromList $ mkTripUpdate nowSeconds <$> anchors
          where mkTripUpdate nowSeconds (Entity (RunningKey (Token uuid)) Running{..}, Trip{..} :: Trip Deep Deep, anchors) =
                  let lastCall = extrapolateAtSeconds @LinearExtrapolator anchors nowSeconds
                      stations = tripStops
                        <&> (\stop@Stop{..} -> fmap (, stop) $ extrapolateAtPosition @LinearExtrapolator anchors (int2Double stopSequence))
                  in (dFeedEntity (Utf8 $ toLazyASCIIBytes uuid))
                  { FE.trip_update = Just $ TripUpdate
                    { TU.trip = dTripDescriptor runningTrip (Just runningDay)
                    , TU.vehicle = Nothing
                    , TU.stop_time_update = Seq.fromList
                      $ fmap (\(TrainAnchor{..}, Stop{..}) -> StopTimeUpdate
                             { STU.stop_sequence = Just (fromIntegral stopSequence)
                             , STU.stop_id = Nothing
                             , STU.arrival = Just (
                                 defaultValue { STE.delay = Just $ fromIntegral $ unSeconds $ trainAnchorDelay })
                             , STU.departure = Nothing
                             , STU.departure_occupancy_status = Nothing
                             , STU.schedule_relationship = Nothing
                             , STU.stop_time_properties = Nothing
                             , STU.ext'field = defaultValue
                             })
                      $ catMaybes $ V.toList stations
                    , TU.delay = lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
                    , TU.timestamp = lastCall <&> (toStupidTime . trainAnchorCreated)
                    , TU.trip_properties = Nothing
                    , TU.ext'field = defaultValue
                    }
                  }

        handleVehiclePositions = runSql dbpool $ do
          (running :: [Entity Running]) <- selectList [] []
          pings <- forM running $ \(Entity key entity) -> do
            selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
          dFeedMessage $ Seq.fromList $ mkPosition <$> catMaybes pings
          where mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) =
                  (dFeedEntity (toUtf8 . T.pack . show $ key))
                  { FE.vehicle = Just $ VehiclePosition
                    { trip = Just (dTripDescriptor runningTrip Nothing)
                    , VP.vehicle = case runningVehicle of
                        Nothing -> Nothing
                        Just trainset -> Just $ VehicleDescriptor
                             { VD.id = Nothing
                             , VD.label = Just (toUtf8 trainset)
                             , VD.license_plate = Nothing
                             , VD.ext'field = defaultValue
                             }
                    , position = Just $ Position
                      { latitude = double2Float trainPingLat
                      , longitude = double2Float trainPingLong
                      , odometer = Nothing
                      , speed = Nothing
                      , bearing = Nothing
                      , POS.ext'field = defaultValue
                      }
                    -- TODO: at least one of these should probably be given
                    , current_stop_sequence = Nothing
                    , stop_id = Nothing
                    , current_status = Nothing
                    , timestamp = Just (toStupidTime trainPingTimestamp)
                    , congestion_level = Nothing
                    , occupancy_status = Nothing
                    , occupancy_percentage = Nothing
                    , multi_carriage_details = []
                    , VP.ext'field = defaultValue
                    }
                  }


lang :: Utf8 -> Utf8 -> TranslatedString
lang code msg = TranslatedString [Translation msg (Just code) defaultValue] defaultValue

-- | a default FeedMessage, issued at the current system time
-- TODO: do we ever need incremental updates?
-- TODO: maybe instead use last update time?
dFeedMessage :: MonadIO m => Seq FeedEntity -> m FeedMessage
dFeedMessage entities = do
  now <- liftIO getSystemTime <&> systemSeconds
  pure $ FeedMessage
    { header = FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue
    , entity = entities
    , FM.ext'field = defaultValue
    }

-- | a dummy FeedEntity (use record updates to add meaningful values to this)
dFeedEntity :: Utf8 -> FeedEntity
dFeedEntity id = FeedEntity
  { id
  , is_deleted = Nothing
  , trip_update = Nothing
  , vehicle = Nothing
  , alert = Nothing
  , shape = Nothing
  , FE.ext'field = defaultValue
  }

dEntitySelector :: EntitySelector
dEntitySelector = EntitySelector
  { agency_id = Nothing
  , route_id = Nothing
  , route_type = Nothing
  , trip = Nothing
  , stop_id = Nothing
  , direction_id = Nothing
  , ES.ext'field = defaultValue
  }

dTripDescriptor :: TripID -> Maybe Day -> TripDescriptor
dTripDescriptor tripID day = TripDescriptor
  { trip_id = Just (toUtf8 tripID)
  , route_id = Nothing
  , direction_id = Nothing
  , start_time = Nothing
  , start_date = fmap toStupidDate day
  , schedule_relationship = Nothing
  , TD.ext'field = defaultValue
  }