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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
{-# 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 OnDeleteCascade OnUpdateCascade
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 OnDeleteCascade OnUpdateCascade
tracker TrackerId OnDeleteCascade OnUpdateCascade
UniqueTrackerTicket ticket tracker
-- raw frames as received from OBUs
TrainPing json sql=tt_trip_ping
ticket TicketId OnDeleteCascade OnUpdateCascade
token TrackerId OnDeleteSetNull OnUpdateCascade
geopos Geopos
timestamp UTCTime
sequence Double
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 OnDeleteCascade OnUpdateCascade
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 OnDeleteCascade OnUpdateCascade
header Text
message Text
url Text Maybe
announcedAt UTCTime Maybe
deriving Generic Show
TickerAnnouncement json sql=tt_ticker
header Text
message Text
archived Bool
created UTCTime
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
|
