@@ -1,6 +1,7 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
45module Obelisk.Command.Project
56 ( InitSource (..)
67 , initProject
@@ -15,6 +16,7 @@ module Obelisk.Command.Project
1516 , toImplDir
1617 ) where
1718
19+import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
1820import Control.Monad
1921import Control.Monad.IO.Class (liftIO)
2022import Control.Monad.State
@@ -22,11 +24,14 @@ import Data.Bits
2224import Data.Function (on)
2325import qualified Data.Text as T
2426import System.Directory
27+import System.Environment (lookupEnv)
2528import System.FilePath
2629import System.IO.Temp
27−import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
30+import System.IO.Unsafe (unsafePerformIO)
31+import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
2832import System.Posix.Files
2933import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)
34+import System.Which (staticWhich)
3035
3136import GitHub.Data.GitData (Branch)
3237import GitHub.Data.Name (Name)
@@ -34,6 +39,7 @@ import GitHub.Data.Name (Name)
3439import Obelisk.App (MonadObelisk)
3540import Obelisk.CliApp
3641import Obelisk.Command.Thunk
42+
3743--TODO: Make this module resilient to random exceptions
3844
3945--TODO: Don't hardcode this
@@ -50,10 +56,10 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource
5056 }
5157
5258data InitSource
53− = InitSource_Default
54− | InitSource_Branch (Name Branch)
55− | InitSource_Symlink FilePath
56− deriving Show
59+ = InitSource_Default
60+ | InitSource_Branch (Name Branch)
61+ | InitSource_Symlink FilePath
62+ deriving Show
5763
5864-- | Path to obelisk directory in given path
5965toObeliskDir :: FilePath -> FilePath
@@ -114,15 +120,16 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do
114120findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
115121findProjectObeliskCommand target = do
116122 myUid <- liftIO getRealUserID
123+ processUmask <- liftIO getUmask
117124 targetStat <- liftIO $ getFileStatus target
118− (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case
125+ (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case
119126 Nothing -> pure Nothing
120127 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case
121128 False -> do
122129 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"
123130 pure Nothing
124131 True -> do
125− walkToImplDir projectRoot myUid -- For security check
132+ walkToImplDir projectRoot myUid processUmask -- For security check
126133 return $ Just projectRoot
127134 case (result, insecurePaths) of
128135 (Just projDir, []) -> do
@@ -133,16 +140,36 @@ findProjectObeliskCommand target = do
133140 putLog Error $ T.unlines
134141 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
135142 , T.unlines $ fmap (T.pack . normalise) insecurePaths
136− , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
143+ , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."
137144 ]
138145 return Nothing
139146
147+-- | Get the umask for the Obelisk process.
148+--
149+-- Because of
150+-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the
151+-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and
152+-- reading isn't interrupted by any exception or interleaved with another thread.
153+getUmask :: IO FileMode
154+getUmask = withMVarMasked globalUmaskLock $ \() -> do
155+ initialMask <- setFileCreationMask safeUmask
156+ void (setFileCreationMask initialMask)
157+ pure initialMask
158+ where
159+ safeUmask :: FileMode
160+ safeUmask = CMode 0o22
161+
162+{-# NOINLINE globalUmaskLock #-}
163+globalUmaskLock :: MVar ()
164+globalUmaskLock = unsafePerformIO (newMVar ())
165+
140166-- | Get the FilePath to the containing project directory, if there is one
141167findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
142168findProjectRoot target = do
143169 myUid <- liftIO getRealUserID
144170 targetStat <- liftIO $ getFileStatus target
145− (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []
171+ umask <- liftIO $ getUmask
172+ (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []
146173 return result
147174
148175withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
@@ -155,15 +182,15 @@ withProjectRoot target f = findProjectRoot target >>= \case
155182-- traversed in the process. Return the project root directory, if found.
156183walkToProjectRoot
157184 :: (MonadState [FilePath] m, MonadIO m)
158− => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)
159−walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case
185+ => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)
186+walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case
160187 -- It's not a directory, so it can't be a project
161188 False -> do
162189 let dir = takeDirectory this
163190 dirStat <- liftIO $ getFileStatus dir
164− walkToProjectRoot dir dirStat myUid
191+ walkToProjectRoot dir dirStat desiredUmask myUid
165192 True -> do
166− when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)
193+ when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)
167194 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case
168195 True -> return $ Just this
169196 False -> do
@@ -173,25 +200,38 @@ walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \ca
173200 isSameFileAs = (==) `on` fileIdentity
174201 if thisStat `isSameFileAs` nextStat
175202 then return Nothing -- Found a cycle; probably hit root directory
176− else walkToProjectRoot next nextStat myUid
203+ else walkToProjectRoot next nextStat desiredUmask myUid
177204
178205-- | Walk from the given project root directory to its Obelisk implementation
179206-- directory, accumulating potentially insecure directories that were traversed
180207-- in the process.
181−walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()
182−walkToImplDir projectRoot myUid = do
208+walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()
209+walkToImplDir projectRoot myUid umask = do
183210 let obDir = toObeliskDir projectRoot
184211 obDirStat <- liftIO $ getFileStatus obDir
185− when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)
212+ when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)
186213 let implThunk = obDir </> "impl"
187214 implThunkStat <- liftIO $ getFileStatus implThunk
188− when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)
215+ when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)
189216
190−--TODO: Is there a better way to ask if anyone else can write things?
191−--E.g. what about ACLs?
192−-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided
193−isWritableOnlyBy :: FileStatus -> UserID -> Bool
194−isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0
217+-- | Check to see if directory is writable by a user whose User ID matches the
218+-- second argument provided, and if the fact that other people can write to that
219+-- directory is in accordance with the umask of the system, passed as the third
220+-- argument.
221+isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool
222+isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask
223+
224+isOwnedBy :: FileStatus -> UserID -> Bool
225+isOwnedBy s uid = fileOwner s == uid
226+
227+-- | Check to see if a directory respect the umask, but check explicitly that
228+-- it's not world writable in any case.
229+filePermissionIsSafe :: FileStatus -> FileMode -> Bool
230+filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable
231+ where
232+ fileWorldWritable = fileMode s .&. 0o002 == 0o002
233+ fileGroupWritable = fileMode s .&. 0o020 == 0o020
234+ umaskGroupWritable = umask .&. 0o020 == 0
195235
196236-- | Run a command in the given shell for the current project
197237inProjectShell :: MonadObelisk m => String -> String -> m ()
@@ -204,16 +244,23 @@ inImpureProjectShell shellName command = withProjectRoot "." $ \root ->
204244
205245projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
206246projectShell root isPure shellName command = do
247+ let nixPath = $(staticWhich "nix")
248+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]
249+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"
207250 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $
208251 [ "default.nix"] <>
209− -- Keep $NIX_PATH in the env for --pure shells so '<nixpkgs>' works in sub-commands
210− -- TODO: Don't use <nixpkgs> for anything!
211− (if isPure then [ "--pure", "--keep", "NIX_PATH" ] else []) <>
252+ ["--pure" | isPure] <>
212253 [ "-A"
213254 , "shells." <> shellName
214255 ] <> case command of
215256 Nothing -> []
216− Just c -> ["--run", c]
257+ Just c ->
258+ -- TODO: Escape nixpkgsPath and nixRemote
259+ [ "--run"
260+ , "export NIX_PATH=nixpkgs=" <> T.unpack nixpkgsPath <> "; " <>
261+ maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote <>
262+ c
263+ ]
217264 void $ liftIO $ waitForProcess ph
218265
219266setCtlc :: CreateProcess -> CreateProcess