diff options
Diffstat (limited to 'lib/Persist.hs')
| -rw-r--r-- | lib/Persist.hs | 57 |
1 files changed, 38 insertions, 19 deletions
diff --git a/lib/Persist.hs b/lib/Persist.hs index 637155a..405e815 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -10,7 +10,7 @@ -- also a few little convenience functions for using persistent. module Persist where -import Data.Aeson (FromJSON, ToJSON, ToJSONKey) +import Data.Aeson (FromJSON, ToJSON, ToJSONKey, Value) import Data.Swagger (ToParamSchema (..), ToSchema (..), genericDeclareNamedSchema) import Data.Text (Text) @@ -50,17 +50,18 @@ import MultiLangText (MultiLangText) import Server.Util (runLogging) import Web.PathPieces (PathPiece) import Yesod (Lang) +import qualified OwnTracks -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) +-- newtype TrackerId = TrackerId UUID +-- deriving newtype +-- ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData +-- , ToJSONKey, PersistField, PersistFieldSql, PathPiece +-- , ToHttpApiData, Read ) +-- instance ToSchema TrackerId where +-- declareNamedSchema _ = declareNamedSchema (Proxy @String) +-- instance ToParamSchema TrackerId where +-- toParamSchema _ = toParamSchema (Proxy @String) deriving newtype instance PersistField GTFS.Seconds deriving newtype instance PersistFieldSql GTFS.Seconds @@ -86,6 +87,13 @@ latitude = fst . unGeoPos longitude :: Geopos -> Double longitude = snd . unGeoPos +-- TODO: this is horrible. make a custom status msg type instead? +derivePersistFieldJSON "Value" + +-- We derive these here so that OwnTracks.* can become its own package eventually +derivePersistFieldJSON "OwnTracks.Status" + + share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Ticket sql=tt_ticket Id UUID default=uuid_generate_v4() @@ -121,27 +129,37 @@ ShapePoint sql=tt_shape_point Shape sql=tt_shape --- | tokens which have been issued -Tracker sql=tt_tracker_token - Id Token default=uuid_generate_v4() +-- | trackerIds which have been issued +Tracker sql=tt_tracker + Id UUID default=uuid_generate_v4() + name Text Unique expires UTCTime blocked Bool agent Text currentTicket TicketId Maybe deriving Eq Show Generic +TrackerStatus sql=tt_tracker_status + tracker TrackerId + timestamp UTCTime + status OwnTracks.Status + 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 +Ping json sql=tt_trip_ping + ticket TicketId Maybe OnDeleteCascade OnUpdateCascade + trackerId TrackerId OnDeleteSetNull OnUpdateCascade geopos Geopos + -- accuracy Int Maybe + -- altitute Int Maybe + -- battery Int Maybe + -- TODO timestamp UTCTime - sequence Double + sequence Double Maybe deriving Show Generic Eq -- status of a train somewhen in time (may be in the future), @@ -156,6 +174,7 @@ TrainAnchor json sql=tt_trip_anchor deriving Show Generic Eq -- TODO: multi-language support? +-- announcements for the gtfs realtime Announcement json sql=tt_announcements Id UUID default=uuid_generate_v4() ticket TicketId OnDeleteCascade OnUpdateCascade @@ -177,8 +196,8 @@ 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 Ping where + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "ping") instance ToSchema TrainAnchor where declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor") instance ToSchema Announcement where |