From 2fd29196405ac6f2aa51d299c37da418cf31f9bf Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 27 Dec 2012 11:52:55 +0200
Subject: [PATCH] Correctly set UID/GID on all created folders (#4)

---
 Keter/App.hs        | 22 ++++++++++++++++++----
 Keter/TempFolder.hs | 14 +++++++++++---
 2 files changed, 29 insertions(+), 7 deletions(-)

diff --git a/Keter/App.hs b/Keter/App.hs
index 3d356c6..fc96cd7 100644
--- a/Keter/App.hs
+++ b/Keter/App.hs
@@ -23,6 +23,7 @@ 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 qualified Filesystem as F
 import Data.Yaml
 import Control.Applicative ((<$>), (<*>))
 import qualified Network
@@ -40,6 +41,7 @@ import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import Data.Text.Encoding (encodeUtf8)
 import System.Posix.Types (UserID, GroupID)
 import System.Posix.Files.ByteString (setOwnerAndGroup, setFdOwnerAndGroup)
+import Control.Monad (unless)
 
 data Config = Config
     { configExec :: F.FilePath
@@ -101,7 +103,7 @@ unpackBundle tf muid bundle appname = do
     case elbs of
         Left e -> return $ Left e
         Right lbs -> do
-            edir <- getFolder tf appname
+            edir <- getFolder muid tf appname
             case edir of
                 Left e -> return $ Left e
                 Right dir -> do
@@ -133,6 +135,19 @@ fixStaticHost dir sh =
     fp0 = shRoot sh
     fp = F.collapse $ dir F.</> "config" F.</> fp0
 
+-- | 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 <- F.isDirectory fp
+        unless exists $ do
+            go $ F.parent fp
+            F.createDirectory False fp
+            setOwnerAndGroup (F.encode fp) uid gid
+
 unpackTar :: Maybe (UserID, GroupID)
           -> FilePath -> Tar.Entries Tar.FormatError -> IO ()
 unpackTar muid dir =
@@ -146,10 +161,9 @@ unpackTar muid dir =
         let fp = dir </> decodeString (Tar.entryPath e)
         case Tar.entryContent e of
             Tar.NormalFile lbs _ -> do
-                createTree $ F.directory fp
                 case muid of
-                    Nothing -> return ()
-                    Just (uid, gid) -> setOwnerAndGroup (F.encode $ F.directory fp) uid gid
+                    Nothing -> createTree $ F.directory fp
+                    Just (uid, gid) -> createTreeUID uid gid $ F.directory fp
                 let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do
                         _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)
                         return ()
diff --git a/Keter/TempFolder.hs b/Keter/TempFolder.hs
index 45e0f96..5e22a7c 100644
--- a/Keter/TempFolder.hs
+++ b/Keter/TempFolder.hs
@@ -12,6 +12,9 @@ import Keter.Prelude
 import Data.Word (Word)
 import Keter.Postgres (Appname)
 import qualified Data.IORef as I
+import System.Posix.Files.ByteString (setOwnerAndGroup)
+import System.Posix.Types (UserID, GroupID)
+import qualified Filesystem.Path.CurrentOS as F
 
 data TempFolder = TempFolder
     { tfRoot :: FilePath
@@ -26,8 +29,13 @@ setup fp = liftIO $ do
     c <- I.newIORef minBound
     return $ TempFolder fp c
 
-getFolder :: TempFolder -> Appname -> KIO (Either SomeException FilePath)
-getFolder TempFolder {..} appname = do
+getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> KIO (Either SomeException FilePath)
+getFolder muid TempFolder {..} appname = do
     !i <- atomicModifyIORef tfCounter $ \i -> (succ i, i)
     let fp = tfRoot </> fromText (appname ++ "-" ++ show i)
-    liftIO (createTree fp >> return fp)
+    liftIO $ do
+        createTree fp
+        case muid of
+            Nothing -> return ()
+            Just (uid, gid) -> setOwnerAndGroup (F.encode fp) uid gid
+        return fp