diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 34 | ||||
| -rw-r--r-- | lib/GTFS.hs | 6 | ||||
| -rw-r--r-- | lib/Persist.hs | 20 | ||||
| -rw-r--r-- | lib/PersistOrphans.hs | 8 | ||||
| -rw-r--r-- | lib/Server.hs | 66 |
5 files changed, 60 insertions, 74 deletions
@@ -1,15 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} - -module API where +-- | The sole authorative definition of this server's API, given as a Servant-style +-- Haskell type. All other descriptions of the API are generated from this one. +module API (API, CompleteAPI) where import Data.Map (Map) import Data.Swagger (Swagger) @@ -21,6 +15,7 @@ import Servant (Application, FromHttpApiData (parseUrlPiece), import Servant.API (Capture, FromHttpApiData, Get, JSON, Post, ReqBody, type (:<|>) ((:<|>))) +-- | The server's API (as it is actually intended). type API = "stations" :> Get '[JSON] (Map StationID Station) :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Map TripID (Trip Deep)) :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep) @@ -31,5 +26,22 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) :<|> "trip" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] () -- debug things :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing]) + +-- | The server's API with an additional debug route for accessing the specification +-- itself. Split from API to prevent the API documenting the format in which it is +-- documented, which would be silly and way to verbose. type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger :<|> API + +{- +TODO: +there should be a basic API allowing the questions: + - what are the next trips leaving from $station? (or $geolocation?) + - all stops of a given tripID + +then the "ingress" API: + - train ping (location, estimated delay, etc.) + - cancel trip + - add trip? + +-} diff --git a/lib/GTFS.hs b/lib/GTFS.hs index a77a487..be80745 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -15,7 +14,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - +-- | All kinds of stuff that has to deal with GTFS directly +-- (i.e. parsing, querying, Aeson instances, etc.) module GTFS where @@ -105,7 +105,7 @@ instance CSV.FromField Day where instance ToSchema Time where declareNamedSchema _ = do dings <- declareNamedSchema (Proxy @Int) - pure $ (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings) + pure (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings) data Depth = Shallow | Deep diff --git a/lib/Persist.hs b/lib/Persist.hs index b4df1fb..3115ce3 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -6,19 +6,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - +-- | Data types that are or might yet be saved in the database, and possibly +-- also a few little convenience functions for using persistent. module Persist where import Data.Aeson (FromJSON, ToJSON, ToJSONKey) @@ -32,7 +29,7 @@ import Database.Persist.Sql (PersistFieldSql, import Database.Persist.TH import GTFS import PersistOrphans -import Servant (FromHttpApiData) +import Servant (FromHttpApiData, ToHttpApiData) import Conduit (ResourceT) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -53,7 +50,8 @@ import Web.PathPieces (PathPiece) newtype Token = Token UUID deriving newtype ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData - , ToJSONKey, PersistField, PersistFieldSql, PathPiece) + , ToJSONKey, PersistField, PersistFieldSql, PathPiece + , ToHttpApiData, Read ) instance ToSchema Token where declareNamedSchema _ = declareNamedSchema (Proxy @String) instance ToParamSchema Token where @@ -62,14 +60,14 @@ instance ToParamSchema Token where share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| RunningTrip sql=tt_tracker_token - Id UUID default=uuid_generate_v4() + Id Token default=uuid_generate_v4() expires UTCTime blocked Bool tripNumber Text deriving Eq Show Generic TripPing json sql=tt_trip_ping - token Token + token RunningTripId latitude Double longitude Double delay Double @@ -78,8 +76,10 @@ TripPing json sql=tt_trip_ping |] +instance ToSchema RunningTripId where + declareNamedSchema _ = declareNamedSchema (Proxy @UUID) instance ToSchema TripPing where declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping") -runSql :: MonadIO m => Pool SqlBackend -> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a) -> m a +runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a runSql pool = liftIO . flip runSqlPersistMPool pool diff --git a/lib/PersistOrphans.hs b/lib/PersistOrphans.hs index 68e9738..1f521cc 100644 --- a/lib/PersistOrphans.hs +++ b/lib/PersistOrphans.hs @@ -1,9 +1,9 @@ --- | This module contains instances for the Data.UUID UUID type --- to be mapped to postgresql's custom builtin uuid type. +-- | 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 +module PersistOrphans () where import Data.Either.Combinators (maybeToRight) @@ -25,8 +25,10 @@ instance PersistField UUID where 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 4a78735..91f1f36 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -1,25 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -module Server where + +-- Implementation of the API. This module is the main point of the program. +module Server (application) where import Conduit (MonadTrans (lift), ResourceT) import Control.Concurrent.STM import Control.Monad (when) @@ -56,7 +45,7 @@ import GTFS import Servant (Application, FromHttpApiData (parseUrlPiece), Server, err401, err404, serve, - throwError, type (:>)) + throwError) import Servant.API (Capture, FromHttpApiData, Get, JSON, Post, ReqBody, type (:<|>) ((:<|>))) @@ -76,8 +65,6 @@ application gtfs dbpool = do doMigration dbpool pure $ serve (Proxy @CompleteAPI) $ server gtfs dbpool - - -- databaseMigration :: ConnectionString -> IO () doMigration pool = runSql pool $ -- TODO: before that, check if the uuid module is enabled @@ -98,23 +85,24 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime Nothing -> throwError err404 handleRegister tripID = do expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod - RunningTripKey uuid <- runSql dbpool $ insert (RunningTrip expires False tripID) - pure (Token uuid) + RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID) + pure token handleTripPing ping = do - checkTokenValid dbpool (tripPingToken ping) + checkTokenValid dbpool (coerce $ tripPingToken ping) -- TODO: are these always inserted in order? runSql dbpool $ insert ping pure () handleDebugState = do - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime runSql dbpool $ do running <- selectList [RunningTripBlocked ==. False, RunningTripExpires >=. now] [] - pairs <- forM running $ \(Entity (RunningTripKey uuid) _) -> do - entities <- selectList [TripPingToken ==. Token uuid] [] - pure (Token uuid, fmap entityVal entities) + pairs <- forM running $ \(Entity token@(RunningTripKey uuid) _) -> do + entities <- selectList [TripPingToken ==. token] [] + pure (uuid, fmap entityVal entities) pure (M.fromList pairs) handleDebugAPI = pure $ toSwagger (Proxy @API) +-- TODO: proper debug logging for expired tokens checkTokenValid :: Pool SqlBackend -> Token -> Handler () checkTokenValid dbpool token = do trip <- try $ runSql dbpool $ get (coerce token) @@ -133,19 +121,3 @@ hasExpired limit = do validityPeriod :: NominalDiffTime validityPeriod = nominalDay - - - - -{- -TODO: -there should be a basic API allowing the questions: - - what are the next trips leaving from $station? (or $geolocation?) - - all stops of a given tripID - -then the "ingress" API: - - train ping (location, estimated delay, etc.) - - cancel trip - - add trip? - --} |