diff options
Diffstat (limited to '')
| -rw-r--r-- | hie.yaml | 3 | ||||
| -rw-r--r-- | lib/GTFS.hs | 52 | ||||
| -rw-r--r-- | lib/Server.hs | 9 |
3 files changed, 54 insertions, 10 deletions
@@ -2,3 +2,6 @@ cradle: cabal: - path: "app/Main.hs" component: "haskell-gtfs:exe:haskell-gtfs" + + - path: "lib" + component: "lib:haskell-gtfs" diff --git a/lib/GTFS.hs b/lib/GTFS.hs index cadc930..35a85ea 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -11,6 +11,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} module GTFS where @@ -33,11 +35,26 @@ 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) +import Data.Aeson + ( ToJSON, + FromJSON, + Options(fieldLabelModifier), + genericParseJSON, + genericToJSON, + defaultOptions ) import qualified Data.Aeson as A import GHC.Generics (Generic) +-- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions) +import qualified Data.Text as T +import Data.Char (toLower) +aesonOptions prefix = + defaultOptions { 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) @@ -89,7 +106,13 @@ data Station = Station , stationName :: Text , stationLat :: Float , stationLon :: Float - } deriving (Show, Generic, ToJSON) + } deriving (Show, Generic) + +instance FromJSON Station where + parseJSON = genericParseJSON (aesonOptions "station") +instance ToJSON Station where + toJSON = genericToJSON (aesonOptions "station") + -- | This is what's called a stop time in GTFS data Stop (deep :: Depth) = Stop @@ -102,8 +125,10 @@ data Stop (deep :: Depth) = Stop deriving instance Show (Stop 'Shallow) deriving instance Show (Stop 'Deep) -deriving instance ToJSON (Stop 'Deep) - +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") data Calendar = Calendar { calServiceId :: Text @@ -116,16 +141,23 @@ data Calendar = Calendar , calSunday :: Bool , calStartDate :: Day , calEndDate :: Day - } deriving (Show, Generic, ToJSON) + } deriving (Show, Generic) + + data CalendarExceptionType = ServiceAdded | ServiceRemoved - deriving (Show, Eq, Generic, ToJSON) + deriving (Show, Eq, Generic, ToJSON, FromJSON) data CalendarDate = CalendarDate { caldateServiceId :: Text , caldateDate :: Day , caldateExceptionType :: CalendarExceptionType - } deriving (Show, Generic, ToJSON) + } deriving (Show, Generic) + +instance FromJSON CalendarDate where + parseJSON = genericParseJSON (aesonOptions "caldate") +instance ToJSON CalendarDate where + toJSON = genericToJSON (aesonOptions "caldate") data Trip (deep :: Depth) = Trip { tripRoute :: Text @@ -141,9 +173,13 @@ data Trip (deep :: Depth) = Trip , tripStops :: Optional deep (Vector (Stop deep)) } deriving Generic + deriving instance Show (Trip Shallow) deriving instance Show (Trip Deep) -deriving instance ToJSON (Trip Deep) +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") -- | helper function to find things in Vectors of things tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a diff --git a/lib/Server.hs b/lib/Server.hs index 0ad451d..7a79aa8 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -26,7 +26,7 @@ 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, FromJSON, ToJSONKey) +import Data.Aeson (ToJSON (toJSON), FromJSON (parseJSON), ToJSONKey, genericToJSON, genericParseJSON) import Servant.Server (Handler) import GHC.Generics (Generic) import GHC.Foreign (withCStringsLen) @@ -40,7 +40,12 @@ data TrainPing = TrainPing , pingLong :: Float , pingDelay :: Int , pingTimestamp :: Time - } deriving (Generic, FromJSON, ToJSON) + } deriving (Generic) + +instance FromJSON TrainPing where + parseJSON = genericParseJSON (aesonOptions "ping") +instance ToJSON TrainPing where + toJSON = genericToJSON (aesonOptions "ping") type KnownTrips = TVar (Map Token [TrainPing]) |