expose the gtfs.zip used in the API

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)