aboutsummaryrefslogtreecommitdiff
path: root/lib/Persist.hs
blob: 637155a262219c289e214c11f0cb1f1c24716af2 (plain)
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