diff options
| -rw-r--r-- | haskell-gtfs.cabal | 10 | ||||
| -rw-r--r-- | lib/PersistOrphans.hs | 34 | ||||
| -rw-r--r-- | lib/Server.hs | 57 |
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: |