aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/GTFS.hs181
-rw-r--r--lib/Server.hs106
2 files changed, 170 insertions, 117 deletions
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 9ad01f1..a77a487 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -1,69 +1,80 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
module GTFS where
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.ByteString as BS
-import qualified Data.Csv as CSV
-import Data.Csv ((.:))
-import qualified Codec.Archive.Zip as Zip
-import qualified Data.Vector as V
-import Data.Vector (Vector)
-import Text.Regex.TDFA ( (=~) )
-import Data.Text (Text)
-import Fmt ( (+|), (|+) )
-import Data.Kind (Type)
-import Data.Maybe (fromMaybe, fromJust)
-import Data.Functor ((<&>))
+import qualified Codec.Archive.Zip as Zip
+import Data.Aeson (FromJSON,
+ Options (fieldLabelModifier),
+ ToJSON, defaultOptions,
+ genericParseJSON,
+ genericToJSON)
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LB
+import Data.Csv ((.:))
+import qualified Data.Csv as CSV
+import Data.Functor ((<&>))
+import Data.Kind (Type)
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Text (Text)
+import Data.Time (UTCTime (utctDay), dayOfWeek,
+ getCurrentTime)
+import Data.Time.Calendar (Day, DayOfWeek (..))
+import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid)
import qualified Data.Time.Calendar.OrdinalDate as Day
-import Data.Time.Calendar (Day, DayOfWeek(..))
-import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid)
-import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek)
-import Data.Aeson
- ( ToJSON,
- FromJSON,
- Options(fieldLabelModifier),
- genericParseJSON,
- genericToJSON,
- defaultOptions )
-import qualified Data.Aeson as A
-import GHC.Generics (Generic)
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Fmt ((+|), (|+))
+import GHC.Generics (Generic)
+import Text.Regex.TDFA ((=~))
-- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
-import qualified Data.Text as T
-import Data.Char (toLower)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Foldable (Foldable(fold))
+import Control.Lens
+import Data.Char (toLower)
+import Data.Foldable (Foldable (fold))
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Proxy (Proxy (Proxy))
+import Data.Swagger (ParamSchema (..),
+ SchemaOptions,
+ ToSchema (declareNamedSchema),
+ defaultSchemaOptions,
+ genericDeclareNamedSchema)
+import qualified Data.Swagger as S
+import qualified Data.Text as T
aesonOptions prefix =
defaultOptions { fieldLabelModifier = fieldModifier (T.length prefix) }
where fieldModifier n label = case drop n label of
c:rest -> toLower c : rest
- "" -> ""
+ "" -> ""
+
+swaggerOptions :: Text -> SchemaOptions
+swaggerOptions prefix =
+ defaultSchemaOptions { S.fieldLabelModifier = fieldModifier (T.length prefix) }
+ where fieldModifier n label = case drop n label of
+ c:rest -> toLower c : rest
+ "" -> ""
newtype Time = Time { toSeconds :: Int }
deriving newtype (ToJSON, FromJSON)
+ deriving (Generic)
instance CSV.FromField Time where
parseField f = do
@@ -72,7 +83,7 @@ instance CSV.FromField Time where
:: (String, String, String, [String])
case subs of
[hh,mm,ss] -> pure $ Time $ read hh * 3600 + read mm * 60 + read ss
- _ -> fail $ "encountered an invalid date: " <> text
+ _ -> fail $ "encountered an invalid date: " <> text
instance Show Time where
show (Time seconds) = ""
@@ -91,6 +102,10 @@ instance CSV.FromField Day where
pure $ Day.fromOrdinalDate (read yyyy) dayOfYear
_ -> fail $ "invalid date encountered: " <> show f
+instance ToSchema Time where
+ declareNamedSchema _ = do
+ dings <- declareNamedSchema (Proxy @Int)
+ pure $ (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings)
data Depth = Shallow | Deep
@@ -109,12 +124,14 @@ type ServiceID = Text
-- | This is what's called a Stop in GTFS
data Station = Station
- { stationId :: StationID
+ { stationId :: StationID
, stationName :: Text
- , stationLat :: Float
- , stationLon :: Float
+ , stationLat :: Float
+ , stationLon :: Float
} deriving (Show, Generic)
+instance ToSchema Station where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
instance FromJSON Station where
parseJSON = genericParseJSON (aesonOptions "station")
instance ToJSON Station where
@@ -123,11 +140,11 @@ instance ToJSON Station where
-- | This is what's called a stop time in GTFS
data Stop (deep :: Depth) = Stop
- { stopTrip :: TripID
- , stopArrival :: Time
+ { stopTrip :: TripID
+ , stopArrival :: Time
, stopDeparture :: Time
- , stopStation :: Switch deep Station StationID
- , stopSequence :: Int
+ , stopStation :: Switch deep Station StationID
+ , stopSequence :: Int
} deriving Generic
deriving instance Show (Stop 'Shallow)
@@ -136,18 +153,20 @@ instance FromJSON (Switch a Station StationID) => FromJSON (Stop a) where
parseJSON = genericParseJSON (aesonOptions "stop")
instance ToJSON (Switch a Station StationID) => ToJSON (Stop a) where
toJSON = genericToJSON (aesonOptions "stop")
+instance ToSchema (Stop Deep)where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "stop")
data Calendar = Calendar
{ calServiceId :: Text
- , calMonday :: Bool
- , calTuesday :: Bool
+ , calMonday :: Bool
+ , calTuesday :: Bool
, calWednesday :: Bool
- , calThursday :: Bool
- , calFriday :: Bool
- , calSaturday :: Bool
- , calSunday :: Bool
+ , calThursday :: Bool
+ , calFriday :: Bool
+ , calSaturday :: Bool
+ , calSunday :: Bool
, calStartDate :: Day
- , calEndDate :: Day
+ , calEndDate :: Day
} deriving (Show, Generic)
@@ -156,8 +175,8 @@ data CalendarExceptionType = ServiceAdded | ServiceRemoved
deriving (Show, Eq, Generic, ToJSON, FromJSON)
data CalendarDate = CalendarDate
- { caldateServiceId :: Text
- , caldateDate :: Day
+ { caldateServiceId :: Text
+ , caldateDate :: Day
, caldateExceptionType :: CalendarExceptionType
} deriving (Show, Generic)
@@ -167,17 +186,17 @@ instance ToJSON CalendarDate where
toJSON = genericToJSON (aesonOptions "caldate")
data Trip (deep :: Depth) = Trip
- { tripRoute :: Text
- , tripTripID :: TripID
- , tripHeadsign :: Maybe Text
+ { tripRoute :: Text
+ , tripTripID :: TripID
+ , tripHeadsign :: Maybe Text
, tripShortName :: Maybe Text
, tripDirection :: Maybe Bool
-- NOTE: there's also block_id, which we're unlikely to ever need
, tripServiceId :: Text
-- , tripWheelchairAccessible :: Bool
-- , tripBikesAllowed :: Bool
- , tripShapeId :: Text
- , tripStops :: Optional deep (Vector (Stop deep))
+ , tripShapeId :: Text
+ , tripStops :: Optional deep (Vector (Stop deep))
} deriving Generic
@@ -187,6 +206,8 @@ instance FromJSON (Optional d (Vector (Stop d))) => FromJSON (Trip d) where
parseJSON = genericParseJSON (aesonOptions "trip")
instance ToJSON (Optional d (Vector (Stop d))) => ToJSON (Trip d) where
toJSON = genericToJSON (aesonOptions "trip")
+instance ToSchema (Trip Deep) where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")
-- | helper function to find things in Vectors of things
tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a
@@ -261,18 +282,18 @@ instance CSV.FromNamedRecord (Trip Shallow) where
<*> pure ()
data RawGTFS = RawGTFS
- { rawStations :: Vector Station
- , rawStops :: Vector (Stop Shallow)
- , rawTrips :: Vector (Trip Shallow)
- , rawCalendar :: Maybe (Vector Calendar)
+ { rawStations :: Vector Station
+ , rawStops :: Vector (Stop Shallow)
+ , rawTrips :: Vector (Trip Shallow)
+ , rawCalendar :: Maybe (Vector Calendar)
, rawCalendarDates :: Maybe (Vector CalendarDate)
}
data GTFS = GTFS
- { stations :: Map StationID Station
- , trips :: Map TripID (Trip Deep)
- , calendar :: Map DayOfWeek (Vector Calendar)
+ { stations :: Map StationID Station
+ , trips :: Map TripID (Trip Deep)
+ , calendar :: Map DayOfWeek (Vector Calendar)
, calendarDates :: Map Day (Vector CalendarDate)
, fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep))
@@ -301,7 +322,7 @@ loadRawGtfs path = do
decodeTable' path zip =
decodeTable path zip >>= \case
Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip"
- Just a -> pure a
+ Just a -> pure a
loadGtfs :: FilePath -> IO GTFS
loadGtfs path = do
diff --git a/lib/Server.hs b/lib/Server.hs
index f9bf36b..d22be59 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,44 +1,65 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Server where
-import Servant (type (:>), Server, serve, err404, throwError, FromHttpApiData (parseUrlPiece), Application)
-import Servant.API (Capture, Get, JSON, type (:<|>) ((:<|>)), FromHttpApiData, ReqBody, Post)
-
-import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Functor ((<&>))
-import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek)
-import GTFS
-import Data.Proxy (Proxy(Proxy))
-import Data.Vector (Vector)
-import Control.Monad.IO.Class (MonadIO(liftIO))
-import Data.Text (Text)
-import qualified Data.UUID.V4 as UUID
-import qualified Data.UUID as UUID
-import Data.UUID (UUID)
-import Control.Concurrent.STM
-import Data.Aeson (ToJSON (toJSON), FromJSON (parseJSON), ToJSONKey, genericToJSON, genericParseJSON)
-import Servant.Server (Handler)
-import GHC.Generics (Generic)
-import GHC.Foreign (withCStringsLen)
+import Servant (Application,
+ FromHttpApiData (parseUrlPiece),
+ Server, err404, serve, throwError,
+ type (:>))
+import Servant.API (Capture, FromHttpApiData, Get, JSON,
+ Post, ReqBody, type (:<|>) ((:<|>)))
+import Servant.Docs (DocCapture (..), DocQueryParam (..),
+ ParamKind (..), ToCapture (..),
+ ToParam (..))
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON),
+ ToJSONKey, genericParseJSON,
+ genericToJSON)
+import qualified Data.Aeson as A
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Proxy (Proxy (Proxy))
+import Data.Swagger
+import Data.Text (Text)
+import Data.Time (UTCTime (utctDay), dayOfWeek,
+ getCurrentTime)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Data.Vector (Vector)
+import GHC.Foreign (withCStringsLen)
+import GHC.Generics (Generic)
+import GTFS
+import Servant.Server (Handler)
+import Servant.Swagger (toSwagger)
+
+
newtype Token = Token UUID
deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey)
+instance ToSchema Token where
+ declareNamedSchema _ = declareNamedSchema (Proxy @String)
+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
+ { pingLat :: Float
+ , pingLong :: Float
+ , pingDelay :: Int
, pingTimestamp :: Time
} deriving (Generic)
@@ -46,7 +67,8 @@ instance FromJSON TrainPing where
parseJSON = genericParseJSON (aesonOptions "ping")
instance ToJSON TrainPing where
toJSON = genericToJSON (aesonOptions "ping")
-
+instance ToSchema TrainPing where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
type KnownTrips = TVar (Map Token [TrainPing])
@@ -55,14 +77,20 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep)
-- ingress API (put this behind BasicAuth?)
-- TODO: perhaps require a first ping for registration?
- :<|> "trainregister" :> Capture "Trip ID" TripID :> Get '[JSON] Token
+ :<|> "trainregister" :> Capture "Trip ID" TripID :> Post '[JSON] Token
-- TODO: perhaps a websocket instead?
:<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TrainPing :> Post '[JSON] ()
-- debug things
:<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing])
+type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
+ :<|> API
+
+
-server :: GTFS -> KnownTrips -> Server API
-server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> handleTrip
+
+
+server :: GTFS -> KnownTrips -> Server CompleteAPI
+server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
:<|> handleRegister :<|> handleTrainPing :<|> handleDebugState
where handleStations = pure stations
handleTimetable station = do
@@ -70,7 +98,7 @@ server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> hand
pure $ tripsOnDay gtfs today
handleTrip trip = case M.lookup trip trips of
Just res -> pure res
- Nothing -> throwError err404
+ Nothing -> throwError err404
handleRegister tripID = liftIO $ do
token <- UUID.nextRandom <&> Token
atomically $ modifyTVar knownTrains (M.insert token [])
@@ -79,11 +107,15 @@ server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> hand
modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token)
pure ()
handleDebugState = liftIO $ readTVarIO knownTrains
+ handleDebugAPI = pure $ toSwagger (Proxy @API)
application :: GTFS -> IO Application
application gtfs = do
knownTrips <- newTVarIO mempty
- pure $ serve (Proxy @API) $ server gtfs knownTrips
+ pure $ serve (Proxy @CompleteAPI) $ server gtfs knownTrips
+
+
+
{-
TODO: