aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2022-06-16 01:06:04 +0200
committerstuebinm2022-06-16 01:06:04 +0200
commit8feb2556eda0604b6710309bf7ffddb72c22fc4a (patch)
treebc3dfc2256bfd7349d415caae8768e35ad4981d1 /lib
parent9e89c93b3b84b5c82c186cff62c33218a0a4d298 (diff)
foreign keys are a thing
(and they can be useful, too!) Also, documentation & deleting imports / extensions that aren't used.
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs34
-rw-r--r--lib/GTFS.hs6
-rw-r--r--lib/Persist.hs20
-rw-r--r--lib/PersistOrphans.hs8
-rw-r--r--lib/Server.hs66
5 files changed, 60 insertions, 74 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 3fb4c3c..dc348d3 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -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?
-
--}