Add tar 0.6 support

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.

use upstream unpack

bump filepath

forM more

import forM

trash result

don't use a traverse but a fold

update changelog

add extra deps

clear stack

add cabal based action

drop windows support

clear stack based ci

Add note on changing to cabal ci

I just don't want to figure out why this broke.

bump keter

Author: jappeace

.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

.github/workflows/stack.yaml

@@ -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
 

ChangeLog.md

@@ -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,

keter.cabal

@@ -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