basic server setup

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?
+
+-}