diff options
| -rw-r--r-- | app/Main.hs | 307 | ||||
| -rw-r--r-- | haskell-gtfs.cabal | 30 | ||||
| -rw-r--r-- | lib/GTFS.hs | 314 | ||||
| -rw-r--r-- | lib/Server.hs | 96 |
4 files changed, 459 insertions, 288 deletions
diff --git a/app/Main.hs b/app/Main.hs index 31c9882..de77adc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,302 +7,35 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | module Main 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 Data.Time.Calendar.OrdinalDate as Day -import Data.Time.Calendar.OrdinalDate (Day) import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid) -import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek) -import Data.Time.Calendar.WeekDate (DayOfWeek(..)) - - -newtype Time = Time { toSeconds :: Int } - -instance CSV.FromField Time where - parseField f = do - text :: String <- CSV.parseField f - let (_,_,_,subs) = text =~ ("([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?)" :: Text) - :: (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 - -instance Show Time where - show (Time seconds) = "" - +|seconds `div` 3600|+":" - +|(seconds `mod` 3600) `div` 60|+":" - +|seconds `mod` 60|+"" - -instance CSV.FromField Day where - parseField f = do - text :: String <- CSV.parseField f - let (_,_,_,subs) = text =~ ("([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])" :: Text) - :: (String, String, String, [String]) - case subs of - [yyyy,mm,dd] -> do - let Just dayOfYear = monthAndDayToDayOfYearValid (Day.isLeapYear (read yyyy)) (read mm) (read dd) - pure $ Day.fromOrdinalDate (read yyyy) dayOfYear - _ -> fail $ "invalid date encountered: " <> show f - - - -data Depth = Shallow | Deep -type Switch :: Depth -> Type -> Type -> Type -type family Switch c a b where - Switch Deep a b = a - Switch Shallow a b = b - -type StationID = Text - --- | This is what's called a Stop in GTFS -data Station = Station - { stationId :: StationID - , stationName :: Text - , stationLat :: Float - , stationLon :: Float - } deriving Show - --- | This is what's called a stop time in GTFS -data Stop (deep :: Depth) = Stop - { stopTrip :: Int - , stopArrival :: Time - , stopDeparture :: Time - , stopStation:: Switch deep Station StationID - , stopSequence :: Int - } - -deriving instance Show (Stop 'Shallow) -deriving instance Show (Stop 'Deep) - - -data Calendar = Calendar - { calServiceId :: Text - , calMonday :: Bool - , calTuesday :: Bool - , calWednesday :: Bool - , calThursday :: Bool - , calFriday :: Bool - , calSaturday :: Bool - , calSunday :: Bool - , calStartDate :: Day - , calEndDate :: Day - } deriving Show - -data CalendarExceptionType = ServiceAdded | ServiceRemoved - deriving (Show, Eq) - -data CalendarDate = CalendarDate - { caldateServiceId :: Text - , caldateDate :: Day - , caldateExceptionType :: CalendarExceptionType - } deriving Show - -type TripID = Text -type ServiceID = Text - -data Trip = Trip - { 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 - } deriving Show - --- | helper function to find things in Vectors of things -tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a -tableLookup proj key = V.find (\a -> proj a == key) - -instance CSV.FromNamedRecord Station where - parseNamedRecord r = Station - <$> r .: "stop_id" - <*> r .: "stop_name" - <*> r .: "stop_lat" - <*> r .: "stop_lon" - -instance CSV.FromNamedRecord (Stop 'Shallow) where - parseNamedRecord r = Stop - <$> r .: "trip_id" - <*> r .: "arrival_time" - <*> r .: "departure_time" - <*> r .: "stop_id" - <*> r .: "stop_sequence" - -instance CSV.FromNamedRecord Calendar where - parseNamedRecord r = Calendar - <$> r .: "service_id" - <*> intAsBool' r "monday" - <*> intAsBool' r "tuesday" - <*> intAsBool' r "wednesday" - <*> intAsBool' r "thursday" - <*> intAsBool' r "friday" - <*> intAsBool' r "saturday" - <*> intAsBool' r "sunday" - <*> r .: "start_date" - <*> r .: "end_date" - -intAsBool :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser (Maybe Bool) -intAsBool r field = do - int <- r .: field - pure $ case int :: Int of - 1 -> Just True - 0 -> Just False - _ -> Nothing - -intAsBool' :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser Bool -intAsBool' r field = intAsBool r field >>= maybe - (fail "unexpected value for a boolean.") - pure - - -instance CSV.FromNamedRecord CalendarDate where - parseNamedRecord r = CalendarDate - <$> r .: "service_id" - <*> r .: "date" - <*> do - int <- r .: "exception_type" - case int :: Int of - 1 -> pure ServiceAdded - 2 -> pure ServiceRemoved - _ -> fail $ "unexpected value in exception_type: "+|int|+"." - - -instance CSV.FromNamedRecord Trip where - parseNamedRecord r = Trip - <$> r .: "route_id" - <*> r .: "trip_id" - <*> r .: "trip_headsign" - <*> r .: "trip_short_name" - <*> intAsBool r "direction_id" - <*> r .: "service_id" - -- NOTE: these aren't booleans but triple-values - -- <*> intAsBool r "wheelchair_accessible" - -- <*> intAsBool r "bikes_allowed" - <*> r .: "shape_id" - -data GTFS (depth :: Depth) = GTFS - { stations :: Vector Station - , stops :: Vector (Stop depth) - , trips :: Vector Trip - , calendar :: Maybe (Vector Calendar) - , calendarDates :: Maybe (Vector CalendarDate) - } - -deriving instance Show (GTFS Shallow) -deriving instance Show (GTFS Deep) - -class Loadable depth where - loadGtfs :: FilePath -> IO (GTFS depth) - -instance Loadable Shallow where - loadGtfs path = do - zip <- Zip.toArchive <$> LB.readFile "./gtfs.zip" - GTFS <$> decodeTable' "stops.txt" zip - <*> decodeTable' "stop_times.txt" zip - <*> decodeTable' "trips.txt" zip - <*> decodeTable "calendar.txt" zip - <*> decodeTable "calendar_dates.txt" zip - where - decodeTable :: CSV.FromNamedRecord a => FilePath -> Zip.Archive -> IO (Maybe (Vector a)) - decodeTable path zip = do - case Zip.findEntryByPath path zip of - Nothing -> pure Nothing - Just csv -> case CSV.decodeByName (Zip.fromEntry csv) of - Left err -> error "blah" - Right (_,v :: a) -> pure (Just v) - decodeTable' path zip = - decodeTable path zip >>= \case - Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip" - Just a -> pure a - -instance Loadable Deep where - loadGtfs path = do - shallow <- loadGtfs @Shallow path - stops' <- V.mapM (pushStop (stations shallow)) (stops shallow) - pure $ shallow { stops = stops' } - where - pushStop :: Vector Station -> Stop Shallow -> IO (Stop Deep) - pushStop stations stop = do - station <- case tableLookup stationId (stopStation stop) stations of - Just a -> pure a - Nothing -> fail $ "station with id "+|stopStation stop|+"is mentioned but not defined." - pure $ stop { stopStation = station } - - - -servicesOnDay :: GTFS Deep -> Day -> Vector ServiceID -servicesOnDay GTFS{..} day = - fmap caldateServiceId added <> V.filter notCancelled regular - where (added,removed) = case calendarDates of - Nothing -> (mempty,mempty) - Just exs -> - V.partition (\cd -> caldateExceptionType cd == ServiceAdded) - $ V.filter (\cd -> caldateDate cd == day) exs - regular = case calendar of - Nothing -> mempty - Just cs -> V.mapMaybe (\cal -> if isRunning cal then Just (calServiceId cal) else Nothing) cs - where isRunning Calendar{..} = - day >= calStartDate && - day <= calEndDate && - case weekday of - Monday -> calMonday - Tuesday -> calTuesday - Wednesday -> calWednesday - Thursday -> calThursday - Friday -> calFriday - Saturday -> calSaturday - Sunday -> calSunday - weekday = dayOfWeek day - notCancelled serviceID = - null (tableLookup caldateServiceId serviceID removed) +import qualified Data.Time.Calendar.OrdinalDate as Day +import qualified Data.ByteString.Lazy as LB +import qualified Data.Aeson as A +import Network.Wai.Middleware.RequestLogger (OutputFormat (..), + RequestLoggerSettings (..), + mkRequestLogger) +import Network.Wai.Handler.Warp (run) +import Data.Default.Class (def) -tripsOfService :: GTFS Deep -> ServiceID -> Vector Trip -tripsOfService GTFS{..} serviceId = - V.filter (\trip -> tripServiceId trip == serviceId ) trips +import GTFS +import Server main :: IO () main = do gtfs <- loadGtfs @Deep "./gtfs.zip" - - -- today <- getCurrentTime <&> utctDay - -- print (calendar gtfs) - let today = Day.fromOrdinalDate 2022 (fromJust $ monthAndDayToDayOfYearValid False 6 6) - print today - - putStrLn "trips today:" - print (fmap (tripsOfService gtfs) (servicesOnDay gtfs today)) - - -{- -TODO: -there should be a basic API allowing the questions: - - what are the next trips leaving from $station? (or $geolocation?) - - all stops of a given tripID - -then the "ingress" API: - - train ping (location, estimated delay, etc.) - - cancel trip - - add trip? - --} + app <- application gtfs + loggerMiddleware <- mkRequestLogger + $ def { outputFormat = Detailed True } + putStrLn "starting server …" + run 4000 (loggerMiddleware app) diff --git a/haskell-gtfs.cabal b/haskell-gtfs.cabal index 642c5d9..a88f351 100644 --- a/haskell-gtfs.cabal +++ b/haskell-gtfs.cabal @@ -37,8 +37,36 @@ executable haskell-gtfs , regex-tdfa >= 1.3.1.2 , text >= 2.0 , fmt >= 0.6.3.0 - , time >= 1.12.2 + , time >= 1.9 + , aeson >= 2.0.3.0 + , haskell-gtfs + , wai-extra + , warp >= 3.3.21 + , 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 + , 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 + , servant >= 0.19 + , servant-server >= 0.19 + , warp >= 3.3.21 + , uuid >= 1.3 + , stm + , containers >= 0.6.5 + hs-source-dirs: lib + exposed-modules: GTFS, Server + default-language: Haskell2010 + default-extensions: OverloadedStrings + , ScopedTypeVariables diff --git a/lib/GTFS.hs b/lib/GTFS.hs new file mode 100644 index 0000000..cadc930 --- /dev/null +++ b/lib/GTFS.hs @@ -0,0 +1,314 @@ +{-# 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 GeneralizedNewtypeDeriving #-} + + +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 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 qualified Data.Aeson as A +import GHC.Generics (Generic) + + +newtype Time = Time { toSeconds :: Int } + deriving newtype (ToJSON, FromJSON) + +instance CSV.FromField Time where + parseField f = do + text :: String <- CSV.parseField f + let (_,_,_,subs) = text =~ ("([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?)" :: Text) + :: (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 + +instance Show Time where + show (Time seconds) = "" + +|seconds `div` 3600|+":" + +|(seconds `mod` 3600) `div` 60|+":" + +|seconds `mod` 60|+"" + +instance CSV.FromField Day where + parseField f = do + text :: String <- CSV.parseField f + let (_,_,_,subs) = text =~ ("([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])" :: Text) + :: (String, String, String, [String]) + case subs of + [yyyy,mm,dd] -> do + let Just dayOfYear = monthAndDayToDayOfYearValid (Day.isLeapYear (read yyyy)) (read mm) (read dd) + pure $ Day.fromOrdinalDate (read yyyy) dayOfYear + _ -> fail $ "invalid date encountered: " <> show f + + + +data Depth = Shallow | Deep +type Switch :: Depth -> Type -> Type -> Type +type family Switch c a b where + Switch Deep a b = a + Switch Shallow a b = b +type family Optional c a where + Optional Deep a = a + Optional Shallow _ = () + +type StationID = Text +type TripID = Text +type ServiceID = Text + + +-- | This is what's called a Stop in GTFS +data Station = Station + { stationId :: StationID + , stationName :: Text + , stationLat :: Float + , stationLon :: Float + } deriving (Show, Generic, ToJSON) + +-- | This is what's called a stop time in GTFS +data Stop (deep :: Depth) = Stop + { stopTrip :: TripID + , stopArrival :: Time + , stopDeparture :: Time + , stopStation:: Switch deep Station StationID + , stopSequence :: Int + } deriving Generic + +deriving instance Show (Stop 'Shallow) +deriving instance Show (Stop 'Deep) +deriving instance ToJSON (Stop 'Deep) + + +data Calendar = Calendar + { calServiceId :: Text + , calMonday :: Bool + , calTuesday :: Bool + , calWednesday :: Bool + , calThursday :: Bool + , calFriday :: Bool + , calSaturday :: Bool + , calSunday :: Bool + , calStartDate :: Day + , calEndDate :: Day + } deriving (Show, Generic, ToJSON) + +data CalendarExceptionType = ServiceAdded | ServiceRemoved + deriving (Show, Eq, Generic, ToJSON) + +data CalendarDate = CalendarDate + { caldateServiceId :: Text + , caldateDate :: Day + , caldateExceptionType :: CalendarExceptionType + } deriving (Show, Generic, ToJSON) + +data Trip (deep :: Depth) = Trip + { 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)) + } deriving Generic + +deriving instance Show (Trip Shallow) +deriving instance Show (Trip Deep) +deriving instance ToJSON (Trip Deep) + +-- | helper function to find things in Vectors of things +tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a +tableLookup proj key = V.find (\a -> proj a == key) + +instance CSV.FromNamedRecord Station where + parseNamedRecord r = Station + <$> r .: "stop_id" + <*> r .: "stop_name" + <*> r .: "stop_lat" + <*> r .: "stop_lon" + +instance CSV.FromNamedRecord (Stop 'Shallow) where + parseNamedRecord r = Stop + <$> r .: "trip_id" + <*> r .: "arrival_time" + <*> r .: "departure_time" + <*> r .: "stop_id" + <*> r .: "stop_sequence" + +instance CSV.FromNamedRecord Calendar where + parseNamedRecord r = Calendar + <$> r .: "service_id" + <*> intAsBool' r "monday" + <*> intAsBool' r "tuesday" + <*> intAsBool' r "wednesday" + <*> intAsBool' r "thursday" + <*> intAsBool' r "friday" + <*> intAsBool' r "saturday" + <*> intAsBool' r "sunday" + <*> r .: "start_date" + <*> r .: "end_date" + +intAsBool :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser (Maybe Bool) +intAsBool r field = do + int <- r .: field + pure $ case int :: Int of + 1 -> Just True + 0 -> Just False + _ -> Nothing + +intAsBool' :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser Bool +intAsBool' r field = intAsBool r field >>= maybe + (fail "unexpected value for a boolean.") + pure + + +instance CSV.FromNamedRecord CalendarDate where + parseNamedRecord r = CalendarDate + <$> r .: "service_id" + <*> r .: "date" + <*> do + int <- r .: "exception_type" + case int :: Int of + 1 -> pure ServiceAdded + 2 -> pure ServiceRemoved + _ -> fail $ "unexpected value in exception_type: "+|int|+"." + + +instance CSV.FromNamedRecord (Trip Shallow) where + parseNamedRecord r = Trip + <$> r .: "route_id" + <*> r .: "trip_id" + <*> r .: "trip_headsign" + <*> r .: "trip_short_name" + <*> intAsBool r "direction_id" + <*> r .: "service_id" + -- NOTE: these aren't booleans but triple-values + -- <*> intAsBool r "wheelchair_accessible" + -- <*> intAsBool r "bikes_allowed" + <*> r .: "shape_id" + <*> pure () + +data GTFS (depth :: Depth) = GTFS + { stations :: Vector Station + , stops :: Vector (Stop depth) + , trips :: Vector (Trip depth) + , calendar :: Maybe (Vector Calendar) + , calendarDates :: Maybe (Vector CalendarDate) + } + +deriving instance Show (GTFS Shallow) +deriving instance Show (GTFS Deep) + +class Loadable depth where + loadGtfs :: FilePath -> IO (GTFS depth) + +instance Loadable Shallow where + loadGtfs path = do + zip <- Zip.toArchive <$> LB.readFile "./gtfs.zip" + GTFS <$> decodeTable' "stops.txt" zip + <*> decodeTable' "stop_times.txt" zip + <*> decodeTable' "trips.txt" zip + <*> decodeTable "calendar.txt" zip + <*> decodeTable "calendar_dates.txt" zip + where + decodeTable :: CSV.FromNamedRecord a => FilePath -> Zip.Archive -> IO (Maybe (Vector a)) + decodeTable path zip = do + case Zip.findEntryByPath path zip of + Nothing -> pure Nothing + Just csv -> case CSV.decodeByName (Zip.fromEntry csv) of + Left err -> error $ "could not decode file "+|path|+": "+|err|+"." + Right (_,v :: a) -> pure (Just v) + decodeTable' path zip = + decodeTable path zip >>= \case + Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip" + Just a -> pure a + +instance Loadable Deep where + loadGtfs path = do + shallow <- loadGtfs @Shallow path + stops' <- V.mapM (pushStop (stations shallow)) (stops shallow) + trips' <- V.mapM (pushTrip stops') (trips shallow) + pure $ shallow { stops = stops', trips = trips' } + where + pushStop :: Vector Station -> Stop Shallow -> IO (Stop Deep) + pushStop stations stop = do + station <- case tableLookup stationId (stopStation stop) stations of + Just a -> pure a + Nothing -> fail $ "station with id "+|stopStation stop|+"is mentioned but not defined." + pure $ stop { stopStation = station } + pushTrip :: Vector (Stop Deep) -> Trip Shallow -> IO (Trip Deep) + pushTrip stops trip = if V.length alongRoute < 2 + then fail $ "trip with id "+|tripTripID trip|+" has no stops" + else pure $ trip { tripStops = alongRoute } + where alongRoute = -- TODO: sort these according to stops + V.filter (\s -> stopTrip s == tripTripID trip) stops + + + +servicesOnDay :: GTFS Deep -> Day -> Vector ServiceID +servicesOnDay GTFS{..} day = + fmap caldateServiceId added <> V.filter notCancelled regular + where (added,removed) = case calendarDates of + Nothing -> (mempty,mempty) + Just exs -> + V.partition (\cd -> caldateExceptionType cd == ServiceAdded) + $ V.filter (\cd -> caldateDate cd == day) exs + regular = case calendar of + Nothing -> mempty + Just cs -> V.mapMaybe (\cal -> if isRunning cal then Just (calServiceId cal) else Nothing) cs + where isRunning Calendar{..} = + day >= calStartDate && + day <= calEndDate && + case weekday of + Monday -> calMonday + Tuesday -> calTuesday + Wednesday -> calWednesday + Thursday -> calThursday + Friday -> calFriday + Saturday -> calSaturday + Sunday -> calSunday + weekday = dayOfWeek day + notCancelled serviceID = + null (tableLookup caldateServiceId serviceID removed) + +tripsOfService :: GTFS Deep -> ServiceID -> Vector (Trip Deep) +tripsOfService GTFS{..} serviceId = + V.filter (\trip -> tripServiceId trip == serviceId ) trips + +-- TODO: this should filter out trips ending there +tripsAtStation :: GTFS Deep -> StationID -> Vector TripID +tripsAtStation GTFS{..} at = fmap stopTrip stops + where + stops = V.filter (\(stop :: Stop Deep) -> stationId (stopStation stop) == at) stops + +tripsOnDay :: GTFS Deep -> Day -> Vector (Trip Deep) +tripsOnDay gtfs today = V.concatMap (tripsOfService gtfs) (servicesOnDay gtfs today) diff --git a/lib/Server.hs b/lib/Server.hs new file mode 100644 index 0000000..0ad451d --- /dev/null +++ b/lib/Server.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + + +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, FromJSON, ToJSONKey) +import Servant.Server (Handler) +import GHC.Generics (Generic) +import GHC.Foreign (withCStringsLen) + +newtype Token = Token UUID + deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey) + +-- TODO: perhaps wrap into server-side struct to add network delay stats? +data TrainPing = TrainPing + { pingLat :: Float + , pingLong :: Float + , pingDelay :: Int + , pingTimestamp :: Time + } deriving (Generic, FromJSON, ToJSON) + + +type KnownTrips = TVar (Map Token [TrainPing]) + +type API = "stations" :> Get '[JSON] (Vector Station) + :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Vector (Trip Deep)) + :<|> "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 + -- TODO: perhaps a websocket instead? + :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TrainPing :> Post '[JSON] () + -- debug things + :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing]) + +server :: GTFS Deep -> KnownTrips -> Server API +server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> handleTrip + :<|> handleRegister :<|> handleTrainPing :<|> handleDebugState + where handleStations = pure stations + handleTimetable station = do + today <- liftIO getCurrentTime <&> utctDay + pure $ tripsOnDay gtfs today + handleTrip trip = case tableLookup tripTripID trip trips of + Just res -> pure res + Nothing -> throwError err404 + handleRegister tripID = liftIO $ do + token <- UUID.nextRandom <&> Token + atomically $ modifyTVar knownTrains (M.insert token []) + pure token + handleTrainPing token ping = liftIO $ do + putStrLn "got train ping" + atomically $ do + modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token) + pure () + handleDebugState = liftIO $ readTVarIO knownTrains + +application :: GTFS Deep -> IO Application +application gtfs = do + knownTrips <- newTVarIO mempty + pure $ serve (Proxy @API) $ server gtfs knownTrips + +{- +TODO: +there should be a basic API allowing the questions: + - what are the next trips leaving from $station? (or $geolocation?) + - all stops of a given tripID + +then the "ingress" API: + - train ping (location, estimated delay, etc.) + - cancel trip + - add trip? + +-} |