{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE QuasiQuotes          #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Data types that are or might yet be saved in the database, and possibly
-- also a few little convenience functions for using persistent.
module Persist where

import           Data.Aeson                  (FromJSON, ToJSON, ToJSONKey)
import           Data.Swagger                (ToParamSchema (..), ToSchema (..),
                                              genericDeclareNamedSchema)
import           Data.Text                   (Text)
import           Data.UUID                   (UUID)
import           Database.Persist
import           Database.Persist.Sql        (PersistFieldSql (..),
                                              runSqlPersistMPool)
import           Database.Persist.TH
import qualified GTFS
import           PersistOrphans
import           Servant                     (FromHttpApiData (..), Handler,
                                              ToHttpApiData)

import           Conduit                     (MonadTrans (lift), MonadUnliftIO,
                                              ResourceT, runResourceT)
import           Config                      (LoggingConfig)
import           Control.Monad.IO.Class      (MonadIO (liftIO))
import           Control.Monad.Logger        (LoggingT, MonadLogger, NoLoggingT,
                                              runNoLoggingT, runStderrLoggingT)
import           Control.Monad.Reader        (MonadReader (ask),
                                              ReaderT (runReaderT), runReader)
import           Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith),
                                              MonadTransControl (liftWith, restoreT))
import           Data.Data                   (Proxy (..))
import           Data.Map                    (Map)
import           Data.Pool                   (Pool)
import           Data.Time                   (NominalDiffTime, TimeOfDay,
                                              UTCTime (utctDay), addUTCTime,
                                              dayOfWeek, diffUTCTime,
                                              getCurrentTime, nominalDay)
import           Data.Time.Calendar          (Day, DayOfWeek (..))
import           Data.Vector                 (Vector)
import           Database.Persist.Postgresql (SqlBackend, runSqlPool)
import           Fmt
import           GHC.Generics                (Generic)
import           MultiLangText               (MultiLangText)
import           Server.Util                 (runLogging)
import           Web.PathPieces              (PathPiece)
import           Yesod                       (Lang)


newtype Token = Token UUID
  deriving newtype
   ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData
   , ToJSONKey, PersistField, PersistFieldSql, PathPiece
   , ToHttpApiData, Read )
instance ToSchema Token where
  declareNamedSchema _ = declareNamedSchema (Proxy @String)
instance ToParamSchema Token where
  toParamSchema _ = toParamSchema (Proxy @String)

deriving newtype instance PersistField GTFS.Seconds
deriving newtype instance PersistFieldSql GTFS.Seconds

instance PersistField GTFS.Time where
  toPersistValue :: GTFS.Time -> PersistValue
  toPersistValue (GTFS.Time seconds zone) = toPersistValue (seconds, zone)
  fromPersistValue :: PersistValue -> Either Text GTFS.Time
  fromPersistValue = fmap (uncurry GTFS.Time) . fromPersistValue

instance PersistFieldSql GTFS.Time where
  sqlType :: Proxy GTFS.Time -> SqlType
  sqlType _ = sqlType (Proxy @(Int, Text))


-- TODO: postgres actually has a native type for this
newtype Geopos = Geopos { unGeoPos :: (Double, Double) }
  deriving newtype (PersistField, PersistFieldSql, Show, Eq, FromJSON, ToJSON, ToSchema)

latitude :: Geopos -> Double
latitude = fst . unGeoPos

longitude :: Geopos -> Double
longitude = snd . unGeoPos

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Ticket sql=tt_ticket
  Id UUID default=uuid_generate_v4()
  tripName Text
  day Day
  imported UTCTime
  schedule_version ImportId Maybe
  vehicle Text Maybe
  completed Bool
  headsign Text
  shape ShapeId

Import sql=tt_imports
  url Text
  date UTCTime

Stop sql=tt_stop
  ticket TicketId
  station StationId
  arrival GTFS.Time
  departure GTFS.Time
  sequence Int

Station sql=tt_station
  geopos Geopos
  shortName Text
  name Text

ShapePoint sql=tt_shape_point
  geopos Geopos
  index Int
  shape ShapeId

Shape sql=tt_shape

-- | tokens which have been issued
Tracker sql=tt_tracker_token
  Id Token default=uuid_generate_v4()
  expires UTCTime
  blocked Bool
  agent Text
  currentTicket TicketId Maybe
  deriving Eq Show Generic

TrackerTicket
  ticket TicketId
  tracker TrackerId
  UniqueTrackerTicket ticket tracker


-- raw frames as received from OBUs
TrainPing json sql=tt_trip_ping
  -- ticket TicketId
  token TrackerId
  geopos Geopos
  timestamp UTCTime
  sequence Double
  ticket TicketId
  deriving Show Generic Eq

-- status of a train somewhen in time (may be in the future),
-- inferred from trainpings / entered via controlRoom
TrainAnchor json sql=tt_trip_anchor
  ticket TicketId
  created UTCTime
  when GTFS.Seconds
  sequence Double
  delay GTFS.Seconds
  msg MultiLangText Maybe
  deriving Show Generic Eq

-- TODO: multi-language support?
Announcement json sql=tt_announcements
  Id UUID default=uuid_generate_v4()
  ticket TicketId
  header Text
  message Text
  url Text Maybe
  announcedAt UTCTime Maybe
  deriving Generic Show
|]

instance ToSchema TicketId where
  declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
instance ToSchema TrackerId where
  declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
instance ToSchema TrainPing where
  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing")
instance ToSchema TrainAnchor where
  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor")
instance ToSchema Announcement where
  declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "announcement")

type InSql a = ReaderT SqlBackend (LoggingT (ResourceT IO)) a

runSqlWithoutLog :: MonadIO m
  => Pool SqlBackend
  -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
  -> m a
runSqlWithoutLog pool = liftIO . flip runSqlPersistMPool pool

-- It's a bit unfortunate that we have an extra reader here for just the
-- logging config, but since Handler is not MonadUnliftIO there seems to be (?)
-- no better way than to nest logger monads …
runSql :: (MonadLogger m, MonadIO m, MonadReader LoggingConfig m)
  => Pool SqlBackend
  -> InSql  a
  -> m a
runSql pool x = do
  conf <- ask
  liftIO $ runResourceT $ runLogging conf $ runSqlPool x pool