Merge pull request #287 from snoyberg/tar-0.6

resolves #286

this uses the upstream tar.
it also has support for changing ownership of the files unpacked (which the keter implementation also seemed to manage).

this also deletes the stack based ci in favor of a cabal based ci, it broke for some reason and I didn't want to play stack whackamole.

.github/workflows/cabal.yaml

@@ -0,0 +1,37 @@
+on: [pull_request]
+jobs:
+  build:
+
+    runs-on: ${{ matrix.os }}
+
+    strategy:
+      fail-fast: false
+      matrix:
+        ghc: # should mirror current stable releases: https://www.haskell.org/ghc/download.html
+          - '9.8'
+          - '9.6'
+          - '9.4'
+          - '9.2'
+        os: [ubuntu-latest, macOS-latest]
+
+    steps:
+    - uses: actions/checkout@v3
+    - uses: haskell/actions/setup@v2 # https://github.com/haskell/actions/tree/main/setup#haskellactionssetup
+      with:
+        ghc-version: ${{ matrix.ghc }}
+
+    - name: Cabal cache
+      uses: actions/cache@v3
+      env:
+        cache-name: cache-cabal
+      with:
+        path: ~/.cabal
+        key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
+        restore-keys: |
+          ${{ runner.os }}-build-${{ env.cache-name }}-
+    - name: Cabal update
+      run: cabal update
+    - name: Build using cabal
+      run: cabal build all
+    - name: Test
+      run: cabal test all

ChangeLog.md

@@ -6,6 +6,8 @@
   accidentally flipped. PR #282
 * In case reading any one of `*-host-response-file` fails, keter now logs a warning,
   and falls back to builtin defaults. Before 2.1.3, this is a fatal error.
+* Add support for tar 0.6, drop NIH tar unpack.
++ Change CI to be cabal based instead of stack.
 
 ## 2.1.2
 

keter.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               keter
-version:            2.1.2
+version:            2.1.3
 synopsis:
   Web application deployment manager, focusing on Haskell web frameworks. It mitigates downtime.
 
@@ -44,7 +44,7 @@ library
       containers >=0.6.4 && <0.7 || ^>=0.7,
       directory >=1.3.6 && <1.4,
       fast-logger >=3.0.0 && <4.0.0,
-      filepath >=1.4.2 && <1.5,
+      filepath >=1.4.2 && <1.6,
       fsnotify >=0.3.0 && <0.5,
       http-client >=0.7.11 && <0.8,
       http-conduit >=2.3.8 && <2.4,
@@ -60,7 +60,7 @@ library
       random >=1.2.1 && <1.3,
       regex-tdfa >=1.3.1 && <1.4,
       stm >=2.5.0 && <2.6,
-      tar >=0.5.1 && <0.6,
+      tar >=0.5.1 && <0.7,
       template-haskell >=2.17.0 && <3.0,
       text >=1.2.5 && <3.0,
       time >=1.9.3 && <2.0,

src/Keter/TempTarball.hs

@@ -15,7 +15,7 @@ import qualified Codec.Archive.Tar.Check   as Tar
 import qualified Codec.Archive.Tar.Entry   as Tar
 import           Codec.Compression.GZip    (decompress)
 import           Control.Exception         (bracket, bracketOnError, throwIO)
-import           Control.Monad             (unless, when)
+import           Control.Monad             (unless, when, forM)
 import qualified Data.ByteString.Lazy      as L
 import           Data.ByteString.Unsafe    (unsafeUseAsCStringLen)
 import qualified Data.IORef                as I
@@ -67,51 +67,13 @@ unpackTempTar :: Maybe (UserID, GroupID)
 unpackTempTar muid tf bundle appname withDir = do
     lbs <- L.readFile bundle
     bracketOnError (getFolder muid tf appname) D.removeDirectoryRecursive $ \dir -> do
-        unpackTar muid dir $ Tar.read $ decompress lbs
+        D.createDirectoryIfMissing True dir
+        let entries = Tar.read $ decompress lbs
+        Tar.unpack dir entries
+        _ <- forM muid $ \perms ->
+          Tar.foldEntries (setEntryPermission perms) (pure ()) throwIO entries
         withDir dir
 
-unpackTar :: Maybe (UserID, GroupID)
-          -> FilePath
-          -> Tar.Entries Tar.FormatError
-          -> IO ()
-unpackTar muid dir =
-    loop . Tar.checkSecurity
-  where
-    loop Tar.Done = return ()
-    loop (Tar.Fail e) = either throwIO throwIO e
-    loop (Tar.Next e es) = go e >> loop es
-
-    go e = do
-        let fp = dir </> Tar.entryPath e
-        case Tar.entryContent e of
-            Tar.NormalFile lbs _ -> do
-                case muid of
-                    Nothing -> D.createDirectoryIfMissing True $ F.takeDirectory fp
-                    Just (uid, gid) -> createTreeUID uid gid $ F.takeDirectory fp
-                let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do
-                        _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)
-                        return ()
-                bracket
-                    (do
-                        fd <- createFile fp $ Tar.entryPermissions e
-                        setFdOption fd CloseOnExec True
-                        case muid of
-                            Nothing -> return ()
-                            Just (uid, gid) -> setFdOwnerAndGroup fd uid gid
-                        return fd)
-                    closeFd
-                    (\fd -> mapM_ (write fd) (L.toChunks lbs))
-            _ -> return ()
-
--- | Create a directory tree, setting the uid and gid of all newly created
--- folders.
-createTreeUID :: UserID -> GroupID -> FilePath -> IO ()
-createTreeUID uid gid =
-    go
-  where
-    go fp = do
-        exists <- D.doesDirectoryExist fp
-        unless exists $ do
-            go $ F.takeDirectory fp
-            D.createDirectoryIfMissing False fp
-            setOwnerAndGroup fp uid gid
+setEntryPermission :: (UserID, GroupID) -> Tar.Entry ->  IO () -> IO ()
+setEntryPermission (uid, gid) entry io =
+  io >> setOwnerAndGroup (Tar.entryPath entry) uid gid