aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haskell-gtfs.cabal10
-rw-r--r--lib/PersistOrphans.hs34
-rw-r--r--lib/Server.hs57
3 files changed, 78 insertions, 23 deletions
diff --git a/haskell-gtfs.cabal b/haskell-gtfs.cabal
index 2bce943..a54a9ff 100644
--- a/haskell-gtfs.cabal
+++ b/haskell-gtfs.cabal
@@ -59,8 +59,16 @@ library
, servant-swagger
, servant-docs
, lens
+ , persistent
+ , persistent-postgresql
+ , monad-logger
+ , mtl
+ , unliftio-core
+ , conduit
+ , path-pieces
+ , either
hs-source-dirs: lib
- exposed-modules: GTFS, Server
+ exposed-modules: GTFS, Server, PersistOrphans
default-language: Haskell2010
default-extensions: OverloadedStrings
, ScopedTypeVariables
diff --git a/lib/PersistOrphans.hs b/lib/PersistOrphans.hs
new file mode 100644
index 0000000..68e9738
--- /dev/null
+++ b/lib/PersistOrphans.hs
@@ -0,0 +1,34 @@
+-- | This module contains instances for the Data.UUID UUID type
+-- to be mapped to postgresql's custom builtin uuid type.
+--
+-- Unfortunately, this breaks compatability with other SQL databases
+-- (though uuids aren't really supported by most anyways)
+module PersistOrphans where
+
+
+import Data.Either.Combinators (maybeToRight)
+import qualified Data.Text as T
+import Data.UUID (UUID)
+import Data.UUID as UUID
+import Data.UUID.V4
+import Database.Persist (PersistField (..),
+ PersistValue (PersistLiteralEscaped),
+ SqlType (SqlOther))
+import Database.Persist.Sql (PersistFieldSql (..), SqlBackend,
+ migrate, runMigration)
+import Web.PathPieces (PathPiece (..))
+
+
+instance PersistField UUID where
+ toPersistValue = PersistLiteralEscaped . UUID.toASCIIBytes
+ fromPersistValue (PersistLiteralEscaped buf) =
+ maybeToRight "not a uuid (cannot decode)" $ UUID.fromASCIIBytes buf
+ fromPersistValue v = Left $ "not a uuid (wrong type in database): " <> T.pack (show v)
+ -- postgres is type-safe, so this should /hopefully/ never happen
+instance PersistFieldSql UUID where
+ sqlType = const $ SqlOther "uuid"
+instance PathPiece UUID where
+ fromPathPiece = UUID.fromText
+ toPathPiece = UUID.toText
+
+
diff --git a/lib/Server.hs b/lib/Server.hs
index d22be59..1b79300 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -4,12 +4,18 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
-
+{-# LANGUAGE UndecidableInstances #-}
module Server where
import Servant (Application,
@@ -40,14 +46,15 @@ import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.Vector (Vector)
+import Database.Persist
+import Database.Persist.TH
import GHC.Foreign (withCStringsLen)
import GHC.Generics (Generic)
import GTFS
+import PersistOrphans
import Servant.Server (Handler)
import Servant.Swagger (toSwagger)
-
-
newtype Token = Token UUID
deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey)
instance ToSchema Token where
@@ -55,22 +62,29 @@ instance ToSchema Token where
instance ToParamSchema Token where
toParamSchema _ = toParamSchema (Proxy @String)
--- TODO: perhaps wrap into server-side struct to add network delay stats?
-data TrainPing = TrainPing
- { pingLat :: Float
- , pingLong :: Float
- , pingDelay :: Int
- , pingTimestamp :: Time
- } deriving (Generic)
-
-instance FromJSON TrainPing where
- parseJSON = genericParseJSON (aesonOptions "ping")
-instance ToJSON TrainPing where
- toJSON = genericToJSON (aesonOptions "ping")
-instance ToSchema TrainPing where
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+TripToken sql=tt_tracker_token
+ Id UUID default=uuid_generate_v4()
+ issued UTCTime
+ blocked Bool
+ tripNumber Text
+ deriving Eq Show Generic
+
+TripPing json sql=tt_trip_ping
+ token UUID
+ latitude Double
+ longitude Double
+ delay Double
+ timestamp UTCTime
+ deriving Show Generic Eq
+
+|]
+
+
+instance ToSchema TripPing where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
-type KnownTrips = TVar (Map Token [TrainPing])
+type KnownTrips = TVar (Map Token [TripPing])
type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Map TripID (Trip Deep))
@@ -79,9 +93,9 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
-- TODO: perhaps require a first ping for registration?
:<|> "trainregister" :> Capture "Trip ID" TripID :> Post '[JSON] Token
-- TODO: perhaps a websocket instead?
- :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TrainPing :> Post '[JSON] ()
+ :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TripPing :> Post '[JSON] ()
-- debug things
- :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing])
+ :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
:<|> API
@@ -91,7 +105,7 @@ type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
server :: GTFS -> KnownTrips -> Server CompleteAPI
server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
- :<|> handleRegister :<|> handleTrainPing :<|> handleDebugState
+ :<|> handleRegister :<|> handleTripPing :<|> handleDebugState
where handleStations = pure stations
handleTimetable station = do
today <- liftIO getCurrentTime <&> utctDay
@@ -103,7 +117,7 @@ server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handl
token <- UUID.nextRandom <&> Token
atomically $ modifyTVar knownTrains (M.insert token [])
pure token
- handleTrainPing token ping = liftIO $ atomically $ do
+ handleTripPing token ping = liftIO $ atomically $ do
modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token)
pure ()
handleDebugState = liftIO $ readTVarIO knownTrains
@@ -116,7 +130,6 @@ application gtfs = do
-
{-
TODO:
there should be a basic API allowing the questions: