From 59b6ab49c3042fa096ee2a1e69b4c57061b5b79e Mon Sep 17 00:00:00 2001
From: Paolo Capriotti <paolo@capriotti.io>
Date: Wed, 11 May 2022 18:57:58 +0200
Subject: [PATCH] Attempt to fix flakyness of path traversal test

Instead of generating `String` values, which might be invalid for the
file system encoding in some locales, generate bytestrings directy and
encode them as paths.
---
 changelog.d/5-internal/develop                |  1 +
 .../src/Federator/Monitor/Internal.hs         |  9 +++++--
 .../test/unit/Test/Federator/Monitor.hs       | 25 ++++++++++++++-----
 3 files changed, 27 insertions(+), 8 deletions(-)
 create mode 100644 changelog.d/5-internal/develop

diff --git a/changelog.d/5-internal/develop b/changelog.d/5-internal/develop
new file mode 100644
index 0000000000..079a78914f
--- /dev/null
+++ b/changelog.d/5-internal/develop
@@ -0,0 +1 @@
+Fix flakyness of path traversal test
diff --git a/services/federator/src/Federator/Monitor/Internal.hs b/services/federator/src/Federator/Monitor/Internal.hs
index ad93fd7686..219acaa6c8 100644
--- a/services/federator/src/Federator/Monitor/Internal.hs
+++ b/services/federator/src/Federator/Monitor/Internal.hs
@@ -18,7 +18,7 @@
 module Federator.Monitor.Internal where
 
 import Control.Exception (try)
-import Data.ByteString (packCStringLen)
+import Data.ByteString (packCStringLen, useAsCStringLen)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
@@ -28,7 +28,7 @@ import qualified Data.X509 as X509
 import Data.X509.CertificateStore
 import Federator.Env (TLSSettings (..))
 import Federator.Options (RunSettings (..))
-import GHC.Foreign (withCStringLen)
+import GHC.Foreign (peekCStringLen, withCStringLen)
 import GHC.IO.Encoding (getFileSystemEncoding)
 import Imports
 import qualified Network.TLS as TLS
@@ -67,6 +67,11 @@ rawPath path = do
   encoding <- getFileSystemEncoding
   withCStringLen encoding path packCStringLen
 
+fromRawPath :: RawFilePath -> IO FilePath
+fromRawPath path = do
+  encoding <- getFileSystemEncoding
+  useAsCStringLen path (peekCStringLen encoding)
+
 data WatchedPath
   = WatchedFile RawFilePath
   | WatchedDir RawFilePath (Set RawFilePath)
diff --git a/services/federator/test/unit/Test/Federator/Monitor.hs b/services/federator/test/unit/Test/Federator/Monitor.hs
index 1995379bc9..dcb2881538 100644
--- a/services/federator/test/unit/Test/Federator/Monitor.hs
+++ b/services/federator/test/unit/Test/Federator/Monitor.hs
@@ -21,6 +21,8 @@ import Control.Concurrent.Chan
 import Control.Exception (bracket)
 import Control.Lens (view)
 import Control.Monad.Trans.Cont
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.Set as Set
 import Data.X509 (CertificateChain (..))
 import Federator.Env (TLSSettings (..), creds)
@@ -395,15 +397,26 @@ testMergeWatchedPaths =
          in mergedPaths == origPaths
     ]
 
-newtype Path = Path {getPath :: FilePath}
+newtype Path = Path {getRawPath :: ByteString}
+
+getPath :: Path -> IO FilePath
+getPath = fromRawPath . getRawPath
+
+getAbsolutePath :: Path -> IO FilePath
+getAbsolutePath p = do
+  path <- getPath p
+  makeAbsolute ("/" <> path)
 
 instance Show Path where
-  show = show . getPath
+  show = show . getRawPath
 
 instance Arbitrary Path where
-  arbitrary = Path . intercalate "/" <$> listOf (listOf1 ch)
+  arbitrary =
+    Path . B8.intercalate "/"
+      <$> listOf (BS.pack <$> listOf1 ch)
     where
-      ch = arbitrary `suchThat` (/= '/')
+      ch :: Gen Word8
+      ch = arbitrary `suchThat` (/= fromIntegral (ord '/'))
 
 trivialResolve :: FilePath -> IO (Maybe FilePath)
 trivialResolve _ = pure Nothing
@@ -414,13 +427,13 @@ testDirectoryTraversal =
     "directory traversal"
     [ testProperty "the number of entries is the same as the number of path components" $
         \(path' :: Path) -> ioProperty $ do
-          path <- makeAbsolute ("/" <> getPath path')
+          path <- getAbsolutePath path'
           wpaths <- watchedPaths trivialResolve path
           pure (length wpaths == length (splitPath path)),
       testProperty "relative paths are resolved correctly" $
         \(path' :: Path) -> ioProperty $ do
           dir <- getWorkingDirectory
-          let path = getPath path'
+          path <- getPath path'
           wpaths <- watchedPaths trivialResolve path
           wpaths' <- watchedPaths trivialResolve (dir </> path)
           pure $ wpaths == wpaths',