diff options
Diffstat (limited to 'lib/GTFS.hs')
| -rw-r--r-- | lib/GTFS.hs | 181 |
1 files changed, 101 insertions, 80 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 |