diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Persist.hs | 66 |
1 files changed, 54 insertions, 12 deletions
diff --git a/lib/Persist.hs b/lib/Persist.hs index b52d7c6..7613fd9 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -16,10 +16,10 @@ import Data.Swagger (ToParamSchema (..), ToSchema (..), import Data.Text (Text) import Data.UUID (UUID) import Database.Persist -import Database.Persist.Sql (PersistFieldSql, +import Database.Persist.Sql (PersistFieldSql (..), runSqlPersistMPool) import Database.Persist.TH -import GTFS +import qualified GTFS import PersistOrphans import Servant (FromHttpApiData (..), ToHttpApiData) @@ -55,22 +55,65 @@ instance ToSchema Token where instance ToParamSchema Token where toParamSchema _ = toParamSchema (Proxy @String) -deriving newtype instance PersistField Seconds -deriving newtype instance PersistFieldSql Seconds +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() - trip TripId + 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 + 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() @@ -89,8 +132,7 @@ TrackerTicket TrainPing json sql=tt_trip_ping ticket TicketId token TrackerId - lat Double - long Double + geopos Geopos timestamp UTCTime deriving Show Generic Eq @@ -99,9 +141,9 @@ TrainPing json sql=tt_trip_ping TrainAnchor json sql=tt_trip_anchor ticket TicketId created UTCTime - when Seconds + when GTFS.Seconds sequence Double - delay Seconds + delay GTFS.Seconds msg MultiLangText Maybe deriving Show Generic Eq @@ -121,11 +163,11 @@ instance ToSchema TicketId where instance ToSchema TrackerId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) instance ToSchema TrainPing where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") instance ToSchema TrainAnchor where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainAnchor") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor") instance ToSchema Announcement where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "announcement") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "announcement") runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a runSql pool = liftIO . flip runSqlPersistMPool pool |