{-# 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           GTFS
import           PersistOrphans
import           Servant                     (FromHttpApiData (..),
                                              ToHttpApiData)

import           Conduit                     (ResourceT)
import           Control.Monad.IO.Class      (MonadIO (liftIO))
import           Control.Monad.Logger        (NoLoggingT)
import           Control.Monad.Reader        (ReaderT)
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)
import           Fmt
import           GHC.Generics                (Generic)
import           MultiLangText               (MultiLangText)
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 Seconds
deriving newtype instance PersistFieldSql Seconds

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Ticket sql=tt_ticket
  Id UUID default=uuid_generate_v4()
  trip TripId
  day Day
  imported UTCTime
  schedule_version ImportId Maybe
  vehicle Text Maybe

Import sql=tt_imports
  url Text
  date UTCTime

-- | tokens which have been issued
Tracker sql=tt_tracker_token
  Id Token default=uuid_generate_v4()
  expires UTCTime
  blocked Bool
  agent Text
  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
  lat Double
  long Double
  timestamp UTCTime
  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 Seconds
  sequence Double
  delay 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 (swaggerOptions "trainPing")
instance ToSchema TrainAnchor where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainAnchor")
instance ToSchema Announcement where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "announcement")

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