Avoid Tar.unpack

snoyberg · Oct 12, 2012 · e0fa8d7 · e0fa8d7
1 parent 5dffbed
commit e0fa8d7
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 7 deletions.
diff --git a/Keter/App.hs b/Keter/App.hs
@@ -9,22 +9,28 @@ module Keter.App
     , Keter.App.terminate
     ) where
 
+import Prelude (IO)
 import Keter.Prelude
 import Keter.TempFolder
 import Keter.Postgres
 import Keter.Process
 import Keter.Logger (Logger, detach)
 import Keter.PortManager hiding (start)
 import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Check as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
 import Codec.Compression.GZip (decompress)
 import qualified Filesystem.Path.CurrentOS as F
 import Data.Yaml
 import Control.Applicative ((<$>), (<*>))
 import System.PosixCompat.Files
 import qualified Network
 import Data.Maybe (fromMaybe)
-import Control.Exception (onException)
+import Control.Exception (onException, throwIO)
 import System.IO (hClose)
+import qualified Data.ByteString.Lazy as L
+import Data.Conduit (($$), yield, runResourceT)
+import Data.Conduit.Binary (sinkFile)
 
 data Config = Config
     { configExec :: F.FilePath
@@ -61,12 +67,29 @@ unpackBundle tf bundle appname = do
                 Right dir -> do
                     log $ UnpackingBundle bundle dir
                     let rest = do
-                            Tar.unpack (F.encodeString dir) $ Tar.read $ decompress lbs
+                            unpackTar dir $ Tar.read $ decompress lbs
                             let configFP = dir F.</> "config" F.</> "keter.yaml"
                             Just config <- decodeFile $ F.encodeString configFP
                             return (dir, config)
                     liftIO $ rest `onException` removeTree dir
 
+unpackTar :: FilePath -> Tar.Entries Tar.FormatError -> IO ()
+unpackTar 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 </> decodeString (Tar.entryPath e)
+        case Tar.entryContent e of
+            Tar.NormalFile lbs _ -> do
+                createTree $ F.directory fp
+                runResourceT $ mapM_ yield (L.toChunks lbs) $$ sinkFile (F.encodeString fp)
+                setFileMode (F.encodeString fp) $ Tar.entryPermissions e
+            _ -> return ()
+
 start :: TempFolder
       -> PortManager
       -> Postgres
@@ -80,10 +103,6 @@ start tf portman postgres logger appname bundle removeFromList = do
     return (App $ writeChan chan, rest chan)
   where
     runApp port dir config = do
-        res1 <- liftIO $ setFileMode (toString $ dir </> "config" </> configExec config) ownerExecuteMode
-        case res1 of
-            Left e -> $logEx e
-            Right () -> return ()
         otherEnv <- do
             mdbi <-
                 if configPostgres config

diff --git a/Keter/Process.hs b/Keter/Process.hs
@@ -51,9 +51,9 @@ run exec dir args env logger = do
                             (Just serr)
                         case res of
                             Left e -> do
+                                $logEx e
                                 void $ liftIO $ return () $$ sout
                                 void $ liftIO $ return () $$ serr
-                                $logEx e
                                 return (NeedsRestart, return ())
                             Right pid -> do
                                 attach logger $ LogPipes pout perr