Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Correctly set UID/GID on all created folders (#4)

  • Loading branch information...
commit 2fd29196405ac6f2aa51d299c37da418cf31f9bf 1 parent 54dbe11
@snoyberg authored
Showing with 29 additions and 7 deletions.
  1. +18 −4 Keter/App.hs
  2. +11 −3 Keter/TempFolder.hs
View
22 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 ()
View
14 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
Please sign in to comment.
Something went wrong with that request. Please try again.