{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# 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.Pool                   (Pool)
import           Data.Time                   (NominalDiffTime,
                                              UTCTime (utctDay), addUTCTime,
                                              dayOfWeek, diffUTCTime,
                                              getCurrentTime, nominalDay, TimeOfDay)
import           Database.Persist.Postgresql (SqlBackend)
import           GHC.Generics                (Generic)
import           Web.PathPieces              (PathPiece)
import Data.Vector (Vector)
import           Data.Time.Calendar             (Day, DayOfWeek (..))

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)

data AmendmentStatus = Cancelled | Added
  deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
derivePersistField "AmendmentStatus"

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- | tokens which have been issued
RunningTrip sql=tt_tracker_token
  Id Token default=uuid_generate_v4()
  expires UTCTime
  blocked Bool
  tripNumber Text
  deriving Eq Show Generic

TripPing json sql=tt_trip_ping
  token RunningTripId
  lat Double
  long Double
  delay Double
  timestamp UTCTime
  deriving Show Generic Eq

Announcements sql=tt_announcements
  trip TripID
  message Text
  day Text

-- | this table works as calendar_dates.txt in GTFS
ScheduleAmendment json sql=tt_schedule_amendement
  trip TripID
  day Text
  status AmendmentStatus
  -- only one special rule per TripID and Day (else incoherent)
  TripAndDay trip day

-- TODO: possible to have regular trips moved in time without changing TripID?
ExtraordinaryTrip sql=tt_extra_trip
  trip TripID
  day Text
  stops (Vector Text)
  stopTimes (Vector TimeOfDay)
|]

instance ToSchema RunningTripId where
  declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
instance ToSchema TripPing where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")

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