diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/GTFS.hs | 181 | ||||
| -rw-r--r-- | lib/Server.hs | 106 |
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: |