Refactor Keter.TempFolder and Keter.App a bit

Keter/App.hs

@@ -16,30 +16,17 @@ import Keter.TempFolder
 import Keter.Process
 import Keter.Types
 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 qualified Filesystem as F
 import Data.Yaml
 import Control.Applicative ((<$>), (<*>), (<|>), pure)
 import qualified Network
 import Data.Maybe (fromMaybe, mapMaybe)
-import Control.Exception (onException, throwIO, bracket)
+import Control.Exception (throwIO)
 import System.IO (hClose)
-import qualified Data.ByteString.Lazy as L
-import Data.Conduit (($$), yield)
 import Data.Set (Set)
 import qualified Data.Set as Set
-import qualified Data.Conduit.List as CL
-import System.Posix.IO (fdWriteBuf, closeFd, FdOption (CloseOnExec), setFdOption, createFile)
-import Foreign.Ptr (castPtr)
-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import Data.Text.Encoding (encodeUtf8)
 import System.Posix.Types (UserID, GroupID)
-import System.Posix.Files (setOwnerAndGroup, setFdOwnerAndGroup)
-import Control.Monad (unless)
 import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog)
 
 data AppConfig = AppConfig
@@ -107,30 +94,20 @@ unpackBundle :: TempFolder
              -> Appname
              -> KIO (Either SomeException (FilePath, Config))
 unpackBundle tf muid bundle appname = do
-    elbs <- readFileLBS bundle
+    log $ UnpackingBundle bundle
-    case elbs of
+    liftIO $ unpackTempTar muid tf bundle appname $ \dir -> do
-        Left e -> return $ Left e
+        let configFP = dir F.</> "config" F.</> "keter.yaml"
-        Right lbs -> do
+        mconfig <- decodeFile $ F.encodeString configFP
-            edir <- getFolder muid tf appname
+        config <-
-            case edir of
+            case mconfig of
-                Left e -> return $ Left e
+                Just config -> return config
-                Right dir -> do
+                Nothing -> throwIO InvalidConfigFile
-                    log $ UnpackingBundle bundle dir
+        return (dir, config
-                    let rest = do
+            { configStaticHosts = Set.fromList
-                            unpackTar muid dir $ Tar.read $ decompress lbs
+                                $ mapMaybe (fixStaticHost dir)
-                            let configFP = dir F.</> "config" F.</> "keter.yaml"
+                                $ Set.toList
-                            mconfig <- decodeFile $ F.encodeString configFP
+                                $ configStaticHosts config
-                            config <-
+            })
-                                case mconfig of
-                                    Just config -> return config
-                                    Nothing -> throwIO InvalidConfigFile
-                            return (dir, config
-                                { configStaticHosts = Set.fromList
-                                                    $ mapMaybe (fixStaticHost dir)
-                                                    $ Set.toList
-                                                    $ configStaticHosts config
-                                })
-                    liftIO $ rest `onException` removeTree dir
 
 -- | Ensures that the given path does not escape the containing folder and sets
 -- the pathname based on config file location.
@@ -143,50 +120,6 @@ 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.encodeString fp) uid gid
-
-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 </> decodeString (Tar.entryPath e)
-        case Tar.entryContent e of
-            Tar.NormalFile lbs _ -> do
-                case muid of
-                    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 ()
-                bracket
-                    (do
-                        fd <- createFile (F.encodeString 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_ yield (L.toChunks lbs) $$ CL.mapM_ (write fd))
-            _ -> return ()
-
 start :: TempFolder
       -> Maybe (Text, (UserID, GroupID))
       -> ProcessTracker

Keter/Main.hs

@@ -106,7 +106,7 @@ keter (F.decodeString -> input) mkPlugins = do
 
     processTracker <- initProcessTracker
     portman <- runThrow $ PortMan.start configPortMan
-    tf <- runThrow $ TempFolder.setup $ configDir </> "temp"
+    tf <- runThrow $ liftIO $ TempFolder.setup $ configDir </> "temp"
     plugins <- runThrow $ loadPlugins $ map ($ configDir) mkPlugins
     mainlog <- runThrow $ liftIO $ LogFile.openRotatingLog
         (F.encodeString $ configDir </> "log" </> "keter")

Keter/Prelude.hs

@@ -157,7 +157,7 @@ data LogMessage
     | ProcessDidNotStart F.FilePath
     | ExceptionThrown T.Text E.SomeException
     | RemovingPort P.Int
-    | UnpackingBundle F.FilePath F.FilePath
+    | UnpackingBundle F.FilePath
     | TerminatingApp T.Text
     | FinishedReloading T.Text
     | TerminatingOldProcess T.Text
@@ -183,11 +183,10 @@ instance P.Show LogMessage where
         , P.show e
         ]
     show (RemovingPort p) = "Port in use, removing from port pool: " ++ P.show p
-    show (UnpackingBundle b dir) = P.concat
+    show (UnpackingBundle b) = P.concat
         [ "Unpacking bundle '"
         , F.encodeString b
-        , "' into folder: "
+        , "'"
-        , F.encodeString dir
         ]
     show (TerminatingApp t) = "Shutting down app: " ++ T.unpack t
     show (FinishedReloading t) = "App finished reloading: " ++ T.unpack t

Keter/TempFolder.hs

@@ -1,41 +1,113 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns      #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+-- | Handles allocation of temporary directories and unpacking of bundles into
+-- them. Sets owner and group of all created files and directories as
+-- necessary.
 module Keter.TempFolder
     ( TempFolder
     , setup
-    , getFolder
+    , unpackTempTar
     ) where
 
-import Keter.Prelude
+import qualified Codec.Archive.Tar         as Tar
-import Data.Word (Word)
+import qualified Codec.Archive.Tar.Check   as Tar
-import Keter.Types (Appname)
+import qualified Codec.Archive.Tar.Entry   as Tar
-import qualified Data.IORef as I
+import           Codec.Compression.GZip    (decompress)
-import System.Posix.Files (setOwnerAndGroup)
+import           Control.Exception         (bracket, bracketOnError, throwIO)
-import System.Posix.Types (UserID, GroupID)
+import           Control.Monad             (unless)
+import qualified Data.ByteString.Lazy      as L
+import           Data.ByteString.Unsafe    (unsafeUseAsCStringLen)
+import qualified Data.IORef                as I
+import           Data.Word                 (Word)
+import qualified Filesystem                as F
 import qualified Filesystem.Path.CurrentOS as F
+import           Foreign.Ptr               (castPtr)
+import           Keter.Prelude
+import           Keter.Types               (Appname)
+import           Prelude                   (IO)
+import           System.Posix.Files        (setFdOwnerAndGroup,
+                                            setOwnerAndGroup)
+import           System.Posix.IO           (FdOption (CloseOnExec), closeFd,
+                                            createFile, fdWriteBuf, setFdOption)
+import           System.Posix.Types        (GroupID, UserID)
 
 data TempFolder = TempFolder
-    { tfRoot :: FilePath
+    { tfRoot    :: FilePath
     , tfCounter :: IORef Word
     }
 
-setup :: FilePath -> KIO (Either SomeException TempFolder)
+setup :: FilePath -> IO TempFolder
-setup fp = liftIO $ do
+setup fp = do
     e <- isDirectory fp
     when e $ removeTree fp
     createTree fp
     c <- I.newIORef minBound
     return $ TempFolder fp c
 
-getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> KIO (Either SomeException FilePath)
+getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> IO FilePath
 getFolder muid TempFolder {..} appname = do
-    !i <- atomicModifyIORef tfCounter $ \i -> (succ i, i)
+    !i <- I.atomicModifyIORef tfCounter $ \i -> (succ i, i)
     let fp = tfRoot </> fromText (appname ++ "-" ++ show i)
-    liftIO $ do
+    createTree fp
-        createTree fp
+    case muid of
-        case muid of
+        Nothing -> return ()
-            Nothing -> return ()
+        Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid
-            Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid
+    return fp
-        return fp
+
+unpackTempTar :: Maybe (UserID, GroupID)
+              -> TempFolder
+              -> FilePath -- ^ bundle
+              -> Appname
+              -> (F.FilePath -> IO a)
+              -> IO a
+unpackTempTar muid tf bundle appname withDir = do
+    lbs <- L.readFile $ F.encodeString bundle
+    bracketOnError (getFolder muid tf appname) removeTree $ \dir -> do
+        unpackTar muid dir $ Tar.read $ decompress lbs
+        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 </> decodeString (Tar.entryPath e)
+        case Tar.entryContent e of
+            Tar.NormalFile lbs _ -> do
+                case muid of
+                    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 ()
+                bracket
+                    (do
+                        fd <- createFile (F.encodeString 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 <- F.isDirectory fp
+        unless exists $ do
+            go $ F.parent fp
+            F.createDirectory False fp
+            setOwnerAndGroup (F.encodeString fp) uid gid