diff options
Diffstat (limited to '')
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | app/Main.hs | 44 | ||||
| -rw-r--r-- | default.nix | 40 | ||||
| -rw-r--r-- | haskell-gtfs.cabal | 34 | ||||
| -rw-r--r-- | lib/GTFS.hs | 181 | ||||
| -rw-r--r-- | lib/Server.hs | 106 | ||||
| -rw-r--r-- | shell.nix | 5 |
7 files changed, 248 insertions, 164 deletions
@@ -1 +1,3 @@ dist-newstyle/* +result +gtfs.zip diff --git a/app/Main.hs b/app/Main.hs index 5b4224a..0b3165e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,34 +1,34 @@ -{-# 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 FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- | module Main where -import Data.Maybe (fromMaybe, fromJust) -import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid) -import qualified Data.Time.Calendar.OrdinalDate as Day -import qualified Data.ByteString.Lazy as LB -import qualified Data.Aeson as A +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as LB +import Data.Default.Class (def) +import Data.Maybe (fromJust, fromMaybe) +import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid) +import qualified Data.Time.Calendar.OrdinalDate as Day +import Network.Wai.Handler.Warp (run) import Network.Wai.Middleware.RequestLogger (OutputFormat (..), RequestLoggerSettings (..), mkRequestLogger) -import Network.Wai.Handler.Warp (run) -import Data.Default.Class (def) -import GTFS -import Server +import GTFS +import Server main :: IO () diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..b2f0e54 --- /dev/null +++ b/default.nix @@ -0,0 +1,40 @@ +{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }: + +let + + inherit (nixpkgs) pkgs; + + f = { mkDerivation, aeson, base, bytestring, cassava, containers + , data-default-class, fmt, lens, lib, regex-tdfa, servant + , servant-docs, servant-server, servant-swagger, stm, swagger2 + , text, time, uuid, vector, wai-extra, warp, zip-archive + }: + mkDerivation { + pname = "haskell-gtfs"; + version = "0.1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson base bytestring cassava containers fmt lens regex-tdfa + servant servant-docs servant-server servant-swagger stm swagger2 + text time uuid vector warp zip-archive + ]; + executableHaskellDepends = [ + aeson base bytestring data-default-class fmt time wai-extra warp + ]; + license = "unknown"; + hydraPlatforms = lib.platforms.none; + }; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; + + drv = variant (haskellPackages.callPackage f {}); + +in + + if pkgs.lib.inNixShell then drv.env else drv diff --git a/haskell-gtfs.cabal b/haskell-gtfs.cabal index a88f351..2bce943 100644 --- a/haskell-gtfs.cabal +++ b/haskell-gtfs.cabal @@ -23,48 +23,42 @@ extra-source-files: CHANGELOG.md executable haskell-gtfs main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: build-depends: base ^>=4.14.3.0 - , zip-archive >= 0.4.2.1 - , cassava >= 0.5.2.0 , bytestring >= 0.10.10.0 - , vector >= 0.12.3.1 - , regex-tdfa >= 1.3.1.2 - , text >= 2.0 , fmt >= 0.6.3.0 , time >= 1.9 - , aeson >= 2.0.3.0 + , aeson , haskell-gtfs , wai-extra - , warp >= 3.3.21 + , warp , data-default-class >= 0.1.2 hs-source-dirs: app default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables + library build-depends: base ^>=4.14.3.0 - , zip-archive >= 0.4.2.1 + , zip-archive , cassava >= 0.5.2.0 , bytestring >= 0.10.10.0 , vector >= 0.12.3.1 - , regex-tdfa >= 1.3.1.2 - , text >= 2.0 + , regex-tdfa + , text , fmt >= 0.6.3.0 , time >= 1.9 - , aeson >= 2.0.3.0 - , servant >= 0.19 - , servant-server >= 0.19 - , warp >= 3.3.21 + , aeson + , servant + , servant-server + , warp , uuid >= 1.3 , stm , containers >= 0.6.5 + , swagger2 + , servant-swagger + , servant-docs + , lens hs-source-dirs: lib exposed-modules: GTFS, Server default-language: Haskell2010 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: diff --git a/shell.nix b/shell.nix deleted file mode 100644 index e010081..0000000 --- a/shell.nix +++ /dev/null @@ -1,5 +0,0 @@ -{ pkgs ? import <nixpkgs> {} }: - -pkgs.mkShell { - buildInputs = [ pkgs.zlib pkgs.openssh ]; -} |