@@ -1,6 +1,7 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
45module Obelisk.Command.Project
56 ( InitSource (..)
67 , initProject
@@ -17,6 +18,7 @@ module Obelisk.Command.Project
1718 , toImplDir
1819 ) where
1920
21+import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
2022import Control.Monad
2123import Control.Monad.IO.Class (liftIO)
2224import Control.Monad.State
@@ -25,12 +27,15 @@ import Data.Bits
2527import Data.Function (on)
2628import qualified Data.Text as T
2729import System.Directory
30+import System.Environment (lookupEnv)
2831import System.FilePath
2932import System.IO.Temp
30−import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
33+import System.IO.Unsafe (unsafePerformIO)
34+import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
3135import System.Posix.Files
3236import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)
3337import Text.ShellEscape (Bash, bytes)
38+import System.Which (staticWhich)
3439
3540import GitHub.Data.GitData (Branch)
3641import GitHub.Data.Name (Name)
@@ -38,6 +43,7 @@ import GitHub.Data.Name (Name)
3843import Obelisk.App (MonadObelisk)
3944import Obelisk.CliApp
4045import Obelisk.Command.Thunk
46+
4147--TODO: Make this module resilient to random exceptions
4248
4349--TODO: Don't hardcode this
@@ -54,10 +60,10 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource
5460 }
5561
5662data InitSource
57− = InitSource_Default
58− | InitSource_Branch (Name Branch)
59− | InitSource_Symlink FilePath
60− deriving Show
63+ = InitSource_Default
64+ | InitSource_Branch (Name Branch)
65+ | InitSource_Symlink FilePath
66+ deriving Show
6167
6268-- | Path to obelisk directory in given path
6369toObeliskDir :: FilePath -> FilePath
@@ -118,15 +124,16 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do
118124findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
119125findProjectObeliskCommand target = do
120126 myUid <- liftIO getRealUserID
127+ processUmask <- liftIO getUmask
121128 targetStat <- liftIO $ getFileStatus target
122− (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case
129+ (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case
123130 Nothing -> pure Nothing
124131 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case
125132 False -> do
126133 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"
127134 pure Nothing
128135 True -> do
129− walkToImplDir projectRoot myUid -- For security check
136+ walkToImplDir projectRoot myUid processUmask -- For security check
130137 return $ Just projectRoot
131138 case (result, insecurePaths) of
132139 (Just projDir, []) -> do
@@ -137,16 +144,36 @@ findProjectObeliskCommand target = do
137144 putLog Error $ T.unlines
138145 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
139146 , T.unlines $ fmap (T.pack . normalise) insecurePaths
140− , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
147+ , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."
141148 ]
142149 return Nothing
143150
151+-- | Get the umask for the Obelisk process.
152+--
153+-- Because of
154+-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the
155+-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and
156+-- reading isn't interrupted by any exception or interleaved with another thread.
157+getUmask :: IO FileMode
158+getUmask = withMVarMasked globalUmaskLock $ \() -> do
159+ initialMask <- setFileCreationMask safeUmask
160+ void (setFileCreationMask initialMask)
161+ pure initialMask
162+ where
163+ safeUmask :: FileMode
164+ safeUmask = CMode 0o22
165+
166+{-# NOINLINE globalUmaskLock #-}
167+globalUmaskLock :: MVar ()
168+globalUmaskLock = unsafePerformIO (newMVar ())
169+
144170-- | Get the FilePath to the containing project directory, if there is one
145171findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
146172findProjectRoot target = do
147173 myUid <- liftIO getRealUserID
148174 targetStat <- liftIO $ getFileStatus target
149− (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []
175+ umask <- liftIO $ getUmask
176+ (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []
150177 return result
151178
152179withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
@@ -159,15 +186,15 @@ withProjectRoot target f = findProjectRoot target >>= \case
159186-- traversed in the process. Return the project root directory, if found.
160187walkToProjectRoot
161188 :: (MonadState [FilePath] m, MonadIO m)
162− => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)
163−walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case
189+ => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)
190+walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case
164191 -- It's not a directory, so it can't be a project
165192 False -> do
166193 let dir = takeDirectory this
167194 dirStat <- liftIO $ getFileStatus dir
168− walkToProjectRoot dir dirStat myUid
195+ walkToProjectRoot dir dirStat desiredUmask myUid
169196 True -> do
170− when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)
197+ when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)
171198 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case
172199 True -> return $ Just this
173200 False -> do
@@ -177,25 +204,38 @@ walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \ca
177204 isSameFileAs = (==) `on` fileIdentity
178205 if thisStat `isSameFileAs` nextStat
179206 then return Nothing -- Found a cycle; probably hit root directory
180− else walkToProjectRoot next nextStat myUid
207+ else walkToProjectRoot next nextStat desiredUmask myUid
181208
182209-- | Walk from the given project root directory to its Obelisk implementation
183210-- directory, accumulating potentially insecure directories that were traversed
184211-- in the process.
185−walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()
186−walkToImplDir projectRoot myUid = do
212+walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()
213+walkToImplDir projectRoot myUid umask = do
187214 let obDir = toObeliskDir projectRoot
188215 obDirStat <- liftIO $ getFileStatus obDir
189− when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)
216+ when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)
190217 let implThunk = obDir </> "impl"
191218 implThunkStat <- liftIO $ getFileStatus implThunk
192− when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)
219+ when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)
193220
194−--TODO: Is there a better way to ask if anyone else can write things?
195−--E.g. what about ACLs?
196−-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided
197−isWritableOnlyBy :: FileStatus -> UserID -> Bool
198−isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0
221+-- | Check to see if directory is writable by a user whose User ID matches the
222+-- second argument provided, and if the fact that other people can write to that
223+-- directory is in accordance with the umask of the system, passed as the third
224+-- argument.
225+isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool
226+isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask
227+
228+isOwnedBy :: FileStatus -> UserID -> Bool
229+isOwnedBy s uid = fileOwner s == uid
230+
231+-- | Check to see if a directory respect the umask, but check explicitly that
232+-- it's not world writable in any case.
233+filePermissionIsSafe :: FileStatus -> FileMode -> Bool
234+filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable
235+ where
236+ fileWorldWritable = fileMode s .&. 0o002 == 0o002
237+ fileGroupWritable = fileMode s .&. 0o020 == 0o020
238+ umaskGroupWritable = umask .&. 0o020 == 0
199239
200240inProjectProc :: MonadObelisk m => String -> [Bash] -> m ()
201241inProjectProc shellName command = withProjectRoot "." $ \root ->
@@ -218,16 +258,23 @@ projectProc root isPure shellName command =
218258
219259projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
220260projectShell root isPure shellName command = do
261+ let nixPath = $(staticWhich "nix")
262+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]
263+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"
221264 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $
222265 [ "default.nix"] <>
223− -- Keep $NIX_PATH in the env for --pure shells so '<nixpkgs>' works in sub-commands
224− -- TODO: Don't use <nixpkgs> for anything!
225− (if isPure then [ "--pure", "--keep", "NIX_PATH" ] else []) <>
266+ ["--pure" | isPure] <>
226267 [ "-A"
227268 , "shells." <> shellName
228269 ] <> case command of
229270 Nothing -> []
230− Just c -> ["--run", c]
271+ Just c ->
272+ -- TODO: Escape nixpkgsPath and nixRemote
273+ [ "--run"
274+ , "export NIX_PATH=nixpkgs=" <> T.unpack nixpkgsPath <> "; " <>
275+ maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote <>
276+ c
277+ ]
231278 void $ liftIO $ waitForProcess ph
232279
233280setCtlc :: CreateProcess -> CreateProcess