From ae2fdbf72745ac46116c70f8435dacd7c227225f Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 20 May 2024 19:51:34 +0200 Subject: use OsPath instead of FilePath in easy cases this is still far from being supported by most libraries, but does make it possible to remove some uses of String (though most times, there is a conversion back to String later). Note that using the default.nix now only works on nixpkgs-unstable for a bit; using the newer filepath package on stable leads to broken other packages. --- default.nix | 5 +++-- lib/Config.hs | 14 ++++++++------ lib/GTFS.hs | 14 ++++++++++---- lib/Server.hs | 4 ++-- lib/Server/Util.hs | 20 ++++++++++++++++---- 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 -- cgit v1.2.3