1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{-# 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
|
