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
|
{-# 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, 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 Web.PathPieces (PathPiece)
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
-- deriving newtype instance PathPiece Seconds
-- deriving newtype instance ToParamSchema Seconds
data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int
deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
derivePersistField "AmendmentStatus"
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- | tokens which have been issued
Running sql=tt_tracker_token
Id Token default=uuid_generate_v4()
expires UTCTime
blocked Bool
trip Text
day Day
vehicle Text Maybe
agent Text
deriving Eq Show Generic
-- raw frames as received from OBUs
TrainPing json sql=tt_trip_ping
token RunningId
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
trip TripID
day Day
created UTCTime
when Seconds
sequence Double
delay Seconds
msg Text Maybe
deriving Show Generic Eq
-- TODO: multi-language support?
Announcement json sql=tt_announcements
Id UUID default=uuid_generate_v4()
trip TripID
header Text
message Text
day Day
url Text Maybe
announcedAt UTCTime Maybe
deriving Generic Show
-- | this table works as calendar_dates.txt in GTFS
ScheduleAmendment json sql=tt_schedule_amendement
trip TripID
day Day
status AmendmentStatus
-- only one special rule per TripID and Day (else incoherent)
TripAndDay trip day
|]
instance ToSchema RunningId 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
|
