diff options
Diffstat (limited to '')
| -rw-r--r-- | default.nix | 5 | ||||
| -rw-r--r-- | lib/Config.hs | 14 | ||||
| -rw-r--r-- | lib/GTFS.hs | 14 | ||||
| -rw-r--r-- | lib/Server.hs | 4 | ||||
| -rw-r--r-- | lib/Server/Util.hs | 20 | ||||
| -rw-r--r-- | tracktrain.cabal | 9 |
6 files changed, 44 insertions, 22 deletions
diff --git a/default.nix b/default.nix index d6ce56c..4b317b9 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ let f = { mkDerivation, aeson, base, blaze-html, blaze-markup , bytestring, cassava, conduit, conferer, conferer-aeson , conferer-warp, conferer-yaml, containers, data-default-class - , directory, either, exceptions, extra, fmt, hoauth2, http-api-data + , directory, either, exceptions, extra, filepath, fmt, hoauth2, http-api-data , http-media, insert-ordered-containers, lens, lib, monad-logger , mtl, path-pieces, persistent, persistent-postgresql , prometheus-client, prometheus-metrics-ghc, proto-lens @@ -27,7 +27,7 @@ let isExecutable = true; libraryHaskellDepends = [ aeson base blaze-html blaze-markup bytestring cassava conduit - conferer conferer-warp containers either exceptions extra fmt + conferer conferer-warp containers either exceptions extra fmt filepath hoauth2 http-api-data http-media insert-ordered-containers lens monad-logger mtl path-pieces persistent persistent-postgresql prometheus-client prometheus-metrics-ghc proto-lens @@ -63,6 +63,7 @@ let # (currently kept as a dummy) hpkgs = haskellPackages.override { overrides = self: super: with pkgs.haskell.lib.compose; { + # filepath = self.filepath_1_4_100_4; # conferer-warp = markUnbroken super.conferer-warp; }; }; diff --git a/lib/Config.hs b/lib/Config.hs index 4aa62fc..ef90fc1 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Config (UffdConfig(..), ServerConfig(..), LoggingConfig(..)) where @@ -9,6 +10,7 @@ import Data.Functor ((<&>)) import Data.Text (Text) import GHC.Generics (Generic) import Network.Wai.Handler.Warp (Settings) +import System.OsPath (OsPath, osp) import URI.ByteString data UffdConfig = UffdConfig @@ -21,9 +23,9 @@ data UffdConfig = UffdConfig data ServerConfig = ServerConfig { serverConfigWarp :: Settings , serverConfigDbString :: ByteString - , serverConfigGtfs :: FilePath - , serverConfigAssets :: FilePath - , serverConfigZoneinfoPath :: FilePath + , serverConfigGtfs :: OsPath + , serverConfigAssets :: OsPath + , serverConfigZoneinfoPath :: OsPath , serverConfigDebugMode :: Bool , serverConfigLogin :: UffdConfig , serverConfigLogging :: LoggingConfig @@ -41,9 +43,9 @@ instance DefaultConfig ServerConfig where configDef = ServerConfig { serverConfigWarp = configDef , serverConfigDbString = "" - , serverConfigGtfs = "./gtfs.zip" - , serverConfigAssets = "./assets" - , serverConfigZoneinfoPath = "/etc/zoneinfo/" + , serverConfigGtfs = [osp|./gtfs.zip|] + , serverConfigAssets = [osp|./assets|] + , serverConfigZoneinfoPath = [osp|/etc/zoneinfo/|] , serverConfigDebugMode = False , serverConfigLogin = configDef , serverConfigLogging = configDef diff --git a/lib/GTFS.hs b/lib/GTFS.hs index cb9be2a..4f3a311 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -65,6 +65,8 @@ import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlson import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries, timeZoneFromSeries) import GHC.Float (int2Double) +import System.OsPath (OsPath, decodeUtf, + encodeUtf, (</>)) -- | for some reason this doesn't exist already in cassava @@ -499,9 +501,9 @@ data GTFS = GTFS } -loadRawGtfs :: FilePath -> IO RawGTFS +loadRawGtfs :: OsPath -> IO RawGTFS loadRawGtfs path = do - bytes <- LB.readFile path + bytes <- decodeUtf path >>= LB.readFile let zip = Zip.toArchive bytes RawGTFS <$> decodeTable' "stops.txt" zip @@ -531,7 +533,7 @@ loadRawGtfs path = do -- -- Note that this additionally needs a path to the machine's timezone info -- (usually /etc/zoneinfo or /usr/shared/zoneinfo) -loadGtfs :: FilePath -> FilePath -> IO GTFS +loadGtfs :: OsPath -> OsPath -> IO GTFS loadGtfs path zoneinforoot = do shallow@RawGTFS{..} <- loadRawGtfs path -- TODO: sort these according to sequence numbers @@ -541,7 +543,11 @@ loadGtfs path zoneinforoot = do (fromMaybe mempty rawShapePoints) -- all agencies must have the same timezone, so just take the first's let tzname = agencyTimezone $ V.head rawAgencies - tzseries <- getTimeZoneSeriesFromOlsonFile (zoneinforoot<>T.unpack tzname) + + tzsuffix <- encodeUtf (T.unpack tzname) + tzseries <- decodeUtf (zoneinforoot </> tzsuffix) + >>= getTimeZoneSeriesFromOlsonFile + let agencies' = fmap (\a -> a { agencyTimezone = tzseries }) rawAgencies routes' <- V.mapM (pushRoute agencies') rawRoutes <&> mapFromVector routeId diff --git a/lib/Server.hs b/lib/Server.hs index 15027b3..3fc2c5a 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -36,7 +36,6 @@ import Prometheus (Info (Info), exportMetricsAsText, gauge, register) import Prometheus.Metric.GHC (ghcMetrics) import Servant (Application, err401, serve, - serveDirectoryFileServer, throwError) import Servant.API ((:<|>) (..)) import Servant.Server (hoistServer) @@ -47,7 +46,8 @@ import Server.GTFS_RT (gtfsRealtimeServer) import Server.Ingest (handleTrackerRegister, handleTrainPing, handleWS) import Server.Subscribe (handleSubscribe) -import Server.Util (Service, runLogging, runService) +import Server.Util (Service, runLogging, runService, + serveDirectoryFileServer) import System.IO.Unsafe (unsafePerformIO) import Yesod (toWaiAppPlain) diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs index 290b9c5..b519a86 100644 --- a/lib/Server/Util.hs +++ b/lib/Server/Util.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE RecordWildCards #-} -- | mostly the monad the service runs in -module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging, getTzseries) where +module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging, getTzseries, serveDirectoryFileServer) where import Config (LoggingConfig (..), ServerConfig (..)) @@ -27,14 +27,18 @@ import Data.Time (Day, UTCTime (..), import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile) import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import Fmt ((+|), (|+)) +import GHC.IO (unsafePerformIO) import GHC.IO.Exception (IOException (IOError)) import GTFS (Seconds (..)) import Prometheus (MonadMonitor (doIO)) +import qualified Servant import Servant (Handler, ServerError, ServerT, err404, errBody, errHeaders, throwError) -import System.FilePath ((</>)) import System.IO (stderr) +import System.OsPath (OsPath, decodeFS, + decodeUtf, encodeUtf, + (</>)) import System.Process.Extra (callProcess) type ServiceM = LoggingT (ReaderT LoggingConfig Handler) @@ -87,5 +91,13 @@ utcToSeconds time day = Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0) getTzseries :: ServerConfig -> Text -> IO TimeZoneSeries -getTzseries settings tzname = getTimeZoneSeriesFromOlsonFile - (serverConfigZoneinfoPath settings </> T.unpack tzname) +getTzseries settings tzname = do + suffix <- encodeUtf (T.unpack tzname) + -- TODO: submit a patch to timezone-olson making it accept OsPath + legacyPath <- decodeFS (serverConfigZoneinfoPath settings </> suffix) + getTimeZoneSeriesFromOlsonFile legacyPath + +-- TODO: patch servant / wai to use OsPath? +serveDirectoryFileServer :: OsPath -> ServerT Servant.Raw m +serveDirectoryFileServer = + Servant.serveDirectoryFileServer . unsafePerformIO . decodeUtf diff --git a/tracktrain.cabal b/tracktrain.cabal index 3c3d72f..45ba246 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -15,7 +15,7 @@ extra-source-files: CHANGELOG.md executable tracktrain main-is: Main.hs ghc-options: -threaded -rtsopts - build-depends: base ^>=4.17 + build-depends: base , bytestring ^>= 0.11 , fmt >= 0.6.3.0 , time @@ -33,6 +33,7 @@ executable tracktrain , directory , extra , proto-lens + , filepath >= 1.4.100 hs-source-dirs: app default-language: GHC2021 default-extensions: OverloadedStrings @@ -40,7 +41,7 @@ executable tracktrain library - build-depends: base ^>=4.17 + build-depends: base , gtfs-realtime , zip-archive , cassava >= 0.5.2.0 @@ -96,7 +97,7 @@ library , exceptions , proto-lens , http-media - , filepath + , filepath >= 1.4.100 , monad-control hs-source-dirs: lib exposed-modules: GTFS @@ -127,7 +128,7 @@ library , ViewPatterns library gtfs-realtime - build-depends: base ^>=4.17 + build-depends: base , proto-lens-runtime default-language: Haskell2010 hs-source-dirs: gtfs-realtime |