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
|
{-# 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 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)
data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int
deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
derivePersistField "AmendmentStatus"
-- instance FromHttpApiData AmendmentStatus where
-- parseUrlPiece "Cancelled" = Right Cancelled
-- parseUrlPiece "Added" = Right Added
-- parseUrlPiece other = Left ("unknown AmendmentStatus: "<>other)
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 ToSchema
-- 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 UTCTime
delay Int Maybe
msg Text Maybe
deriving Show Generic Eq ToSchema
-- 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 ToSchema 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)
runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
runSql pool = liftIO . flip runSqlPersistMPool pool
|
