aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/API.hs34
-rw-r--r--lib/GTFS.hs20
-rw-r--r--lib/Server.hs15
-rw-r--r--lib/Server/ControlRoom.hs6
-rw-r--r--lib/Server/GTFS_RT.hs3
5 files changed, 49 insertions, 29 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 5bf9877..5ea1c06 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
-- | The sole authorative definition of this server's API, given as a Servant-style
-- Haskell type. All other descriptions of the API are generated from this one.
@@ -10,30 +11,33 @@ module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..)) wh
import Data.Map (Map)
import Data.Proxy (Proxy (..))
import Data.Swagger (MimeList (MimeList),
- Operation (..),
+ NamedSchema (..), Operation (..),
PathItem (_pathItemGet),
Scheme (Wss), Swagger,
+ SwaggerType (SwaggerObject),
ToSchema (..), _swaggerPaths,
- genericDeclareNamedSchema, type_,
- NamedSchema(..), SwaggerType (SwaggerObject))
+ genericDeclareNamedSchema, type_)
import Data.Swagger.ParamSchema (ToParamSchema (..))
import Data.Text (Text)
import Data.Time (Day, UTCTime)
import Data.UUID (UUID)
import Servant (Application, FormUrlEncoded,
FromHttpApiData (parseUrlPiece),
- Server, err401, err404, type (:>))
-import Servant.API (Capture, Get, JSON, NoContent,
- PlainText, Post, QueryParam, Raw,
- ReqBody, type (:<|>) ((:<|>)))
+ MimeRender (..), Server, err401,
+ err404, type (:>))
+import Servant.API (Capture, Get, JSON, MimeRender,
+ NoContent, OctetStream, PlainText,
+ Post, QueryParam, Raw, ReqBody,
+ type (:<|>) (..))
import Servant.API.WebSocket (WebSocket)
import Servant.GTFS.Realtime (Proto)
import Servant.Swagger (HasSwagger (..))
import Web.Internal.FormUrlEncoded (Form)
import Control.Lens (At (at), (&), (?~))
-import Data.Aeson (FromJSON (..), genericParseJSON, Value)
-import Data.ByteString.Lazy (ByteString)
+import Data.Aeson (FromJSON (..), Value,
+ genericParseJSON)
+import Data.ByteString (ByteString)
import Data.HashMap.Strict.InsOrd (singleton)
import GHC.Generics (Generic)
import GTFS
@@ -71,6 +75,7 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
:<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
:<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
+ :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile
:<|> "gtfs" :> GtfsRealtimeAPI
-- | The API used for publishing gtfs realtime updates
@@ -93,6 +98,8 @@ type CompleteAPI =
data Metrics = Metrics
{ metricsWSGauge :: Gauge }
+instance MimeRender OctetStream GTFSFile where
+ mimeRender p (GTFSFile bytes) = mimeRender p bytes
@@ -109,3 +116,4 @@ instance HasSwagger WebSocket where
}
}
}
+
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 2bcfdd5..a2718b1 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -35,6 +35,7 @@ import Data.Function (on)
import Data.Functor ((<&>))
import Data.Kind (Type)
import Data.Maybe (fromJust, fromMaybe)
+import qualified Data.Swagger as Swagger
import Data.Text (Text)
import Data.Time (TimeZone (timeZoneMinutes),
UTCTime (..), dayOfWeek,
@@ -474,6 +475,10 @@ instance CSV.FromNamedRecord (Route Shallow) where
<*> r .:? "network_id"
+newtype GTFSFile = GTFSFile ByteString
+instance ToSchema GTFSFile where
+ declareNamedSchema _ = pure $ Swagger.NamedSchema (Just "gtfs.zip") $ mempty
+ & Swagger.type_ ?~ Swagger.SwaggerArray
data RawGTFS = RawGTFS
{ rawStations :: Vector Station
@@ -484,6 +489,7 @@ data RawGTFS = RawGTFS
, rawShapePoints :: Maybe (Vector ShapePoint)
, rawAgencies :: Vector (Agency Shallow)
, rawRoutes :: Vector (Route Shallow)
+ , rawGtfsFile :: GTFSFile
}
@@ -497,12 +503,14 @@ data GTFS = GTFS
-- ^ not a Map AgencyID Agency since if there's only one agency, it may lack an ID
, routes :: Map Text (Route Deep)
, tzseries :: TimeZoneSeries
+ , gtfsFile :: GTFSFile
}
loadRawGtfs :: FilePath -> IO RawGTFS
loadRawGtfs path = do
- zip <- Zip.toArchive <$> LB.readFile path
+ bytes <- LB.readFile path
+ let zip = Zip.toArchive bytes
RawGTFS
<$> decodeTable' "stops.txt" zip
<*> decodeTable' "stop_times.txt" zip
@@ -512,6 +520,7 @@ loadRawGtfs path = do
<*> decodeTable "shapes.txt" zip
<*> decodeTable' "agency.txt" zip
<*> decodeTable' "routes.txt" zip
+ <*> pure (GTFSFile $ LB.toStrict bytes)
where
decodeTable :: CSV.FromNamedRecord a => FilePath -> Zip.Archive -> IO (Maybe (Vector a))
decodeTable path zip =
@@ -562,10 +571,11 @@ loadGtfs path zoneinforoot = do
, agencies = agencies'
, routes = routes'
, tzseries
+ , gtfsFile = rawGtfsFile
}
where
mapFromVector :: Ord k => (a -> k) -> Vector a -> Map k a
- mapFromVector by v = M.fromList $ fmap (\a -> (by a,a)) $ V.toList v
+ mapFromVector by v = M.fromList $ (\a -> (by a,a)) <$> V.toList v
weekdays Calendar{..} =
[Monday | calMonday]
<> [Tuesday | calTuesday]
@@ -629,7 +639,7 @@ servicesOnDay GTFS{..} day =
. fromMaybe mempty $ M.lookup day calendarDates
regular = fmap calServiceId
$ V.filter (\Calendar{..} -> day >= calStartDate && day <= calEndDate)
- $ maybe mempty id
+ $ fromMaybe mempty
$ M.lookup (dayOfWeek day) calendar
notCancelled serviceID =
null (tableLookup caldateServiceId serviceID removed)
@@ -657,6 +667,4 @@ runsToday gtfs trip = do
pure (runsOnDay gtfs trip today)
tripName :: Trip a b -> Text
-tripName Trip{..} = case tripShortName of
- Just name -> name
- Nothing -> tripTripID
+tripName Trip{..} = fromMaybe tripTripID tripShortName
diff --git a/lib/Server.hs b/lib/Server.hs
index 7fdfd71..d6e9955 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -7,14 +8,14 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE DataKinds #-}
-- Implementation of the API. This module is the main point of the program.
module Server (application) where
import Control.Concurrent.STM (TQueue, TVar, atomically,
- newTQueue, newTVar, readTQueue,
- readTVar, writeTQueue, writeTVar, newTVarIO)
+ newTQueue, newTVar, newTVarIO,
+ readTQueue, readTVar, writeTQueue,
+ writeTVar)
import Control.Monad (forever, unless, void, when)
import Control.Monad.Catch (handle)
import Control.Monad.Extra (ifM, maybeM, unlessM, whenJust,
@@ -23,8 +24,8 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LoggingT, logWarnN)
import Control.Monad.Reader (forM)
import Control.Monad.Trans (lift)
-import qualified Data.Aeson as A
import Data.Aeson ((.=))
+import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as C8
import Data.Coerce (coerce)
import Data.Functor ((<&>))
@@ -45,7 +46,9 @@ import Fmt ((+|), (|+))
import qualified Network.WebSockets as WS
import Servant (Application,
ServerError (errBody), err401,
- err404, serve, throwError, serveDirectoryFileServer)
+ err404, serve,
+ serveDirectoryFileServer,
+ throwError)
import Servant.API (NoContent (..), (:<|>) (..))
import Servant.Server (Handler, hoistServer)
import Servant.Swagger (toSwagger)
@@ -90,7 +93,7 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
:<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip
:<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
:<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain
- :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool)
+ :<|> handleDebugRegister :<|> pure gtfsFile :<|> gtfsRealtimeServer gtfs dbpool)
:<|> metrics
:<|> serveDirectoryFileServer (serverConfigAssets settings)
:<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings)))
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 9cde587..8fef7f9 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -31,8 +31,8 @@ import qualified Data.Map as M
import Data.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Time (UTCTime (..), getCurrentTime,
- utctDay, addDays)
+import Data.Time (UTCTime (..), addDays,
+ getCurrentTime, utctDay)
import Data.Time.Calendar (Day)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.UUID (UUID)
@@ -194,7 +194,7 @@ getTrainsR = do
(day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today ->
case maybeDay of
Just day -> (day, day == today)
- Nothing -> (today, True)
+ Nothing -> (today, True)
let prevday = (T.pack . iso8601Show . addDays (-1)) day
let nextday = (T.pack . iso8601Show . addDays 1) day
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 984e19d..5b485df 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -91,7 +91,8 @@ import Data.UUID (t
import qualified Data.Vector as V
import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
LinearExtrapolator (..))
-import GTFS (Depth (..), showTimeWithSeconds)
+import GTFS (Depth (..),
+ showTimeWithSeconds)
import GTFS.Realtime.TripUpdate (TripUpdate (TripUpdate))
import Server.Util (Service,
secondsNow)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 17:58:11 +0000