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