diff options
Diffstat (limited to '')
-rw-r--r-- | lib/API.hs | 34 | ||||
-rw-r--r-- | lib/GTFS.hs | 20 | ||||
-rw-r--r-- | lib/Server.hs | 15 | ||||
-rw-r--r-- | lib/Server/ControlRoom.hs | 6 | ||||
-rw-r--r-- | lib/Server/GTFS_RT.hs | 3 |
5 files changed, 49 insertions, 29 deletions
@@ -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) |