git.iko.soy/obelisk
on eac@ghcide help sign in
obelisk/lib/command/src/Obelisk/Command/Project.hs
344 lines 15 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Obelisk.Command.Project
5 ( InitSource (..)
6 , findProjectObeliskCommand
7 , findProjectRoot
8 , findProjectAssets
9 , initProject
10 , nixShellRunConfig
11 , nixShellRunProc
12 , nixShellWithHoogle
13 , nixShellWithoutPkgs
14 , obeliskDirName
15 , toImplDir
16 , toObeliskDir
17 , withProjectRoot
18 ) where
20import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
21import Control.Lens ((.~), (?~), (<&>))
22import Control.Monad
23import Control.Monad.IO.Class (liftIO)
24import Control.Monad.State
25import qualified Data.Aeson as Json
26import Data.Bits
27import qualified Data.ByteString.Lazy as BSL
28import Data.Default (def)
29import Data.Function ((&), on)
30import Data.Map (Map)
31import Data.Text (Text)
32import qualified Data.Text as T
33import Data.Text.Encoding (decodeUtf8)
34import Data.Traversable (for)
35import System.Directory
36import System.Environment (lookupEnv)
37import System.FilePath
38import System.IO.Temp
39import System.IO.Unsafe (unsafePerformIO)
40import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
41import System.Posix.Files
43import GitHub.Data.GitData (Branch)
44import GitHub.Data.Name (Name)
46import Obelisk.App (MonadObelisk)
47import Obelisk.CliApp
48import Obelisk.Command.Nix
49import Obelisk.Command.Thunk
50import Obelisk.Command.Utils (nixBuildExePath, nixExePath, toNixPath)
52--TODO: Make this module resilient to random exceptions
54--TODO: Don't hardcode this
55-- | Source for the Obelisk project
56obeliskSource :: ThunkSource
57obeliskSource = obeliskSourceWithBranch "master"
59-- | Source for obelisk developer targeting a specific obelisk branch
60obeliskSourceWithBranch :: Name Branch -> ThunkSource
61obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource
62 { _gitHubSource_owner = "obsidiansystems"
63 , _gitHubSource_repo = "obelisk"
64 , _gitHubSource_branch = Just branch
65 , _gitHubSource_private = False
66 }
68data InitSource
69 = InitSource_Default
70 | InitSource_Branch (Name Branch)
71 | InitSource_Symlink FilePath
72 deriving Show
74obeliskDirName :: FilePath
75obeliskDirName = ".obelisk"
77-- | Path to obelisk directory in given path
78toObeliskDir :: FilePath -> FilePath
79toObeliskDir p = p </> obeliskDirName
81-- | Path to impl file in given path
82toImplDir :: FilePath -> FilePath
83toImplDir p = toObeliskDir p </> "impl"
85-- | Create a new project rooted in the current directory
86initProject :: MonadObelisk m => InitSource -> Bool -> m ()
87initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do
88 let implDir = toImplDir tmpDir
89 obDir = toObeliskDir tmpDir
90 liftIO (listDirectory ".") >>= \case
91 [] -> pure ()
92 _ | force -> putLog Warning "Initializing in non-empty directory"
93 | otherwise -> failWith "ob init requires an empty directory. Use the flag --force to init anyway, potentially overwriting files."
94 skeleton <- withSpinner "Setting up obelisk" $ do
95 liftIO $ createDirectory obDir
96 -- Clone the git source and repack it with the init source obelisk
97 -- The purpose of this is to ensure we use the correct thunk spec.
98 let cloneAndRepack src = do
99 putLog Debug $ "Cloning obelisk into " <> T.pack implDir <> " and repacking using itself"
100 commit <- getLatestRev src
101 gitCloneForThunkUnpack (thunkSourceToGitSource src) (_thunkRev_commit commit) implDir
102 callHandoffOb implDir ["thunk", "pack", implDir]
103 case source of
104 InitSource_Default -> cloneAndRepack obeliskSource
105 InitSource_Branch branch -> cloneAndRepack $ obeliskSourceWithBranch branch
106 InitSource_Symlink path -> do
107 let symlinkPath = if isAbsolute path
108 then path
109 else ".." </> path
110 liftIO $ createSymbolicLink symlinkPath implDir
111 _ <- nixBuildAttrWithCache implDir "command"
112 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
114 callProcessAndLogOutput (Notice, Error) $
115 proc "cp"
116 [ "-r"
117 , "--preserve=links"
118 , obDir
119 , toObeliskDir "."
120 ]
121 pure skel
123 withSpinner "Copying project skeleton" $ do
124 callProcessAndLogOutput (Notice, Error) $
125 proc "cp"
126 [ "-r"
127 , "--no-preserve=mode"
128 , "-T"
129 , skeleton </> "."
130 , "."
131 ]
132 liftIO $ do
133 let configDir = "config"
134 createDirectoryIfMissing False configDir
135 mapM_ (createDirectoryIfMissing False . (configDir </>)) ["backend", "common", "frontend"]
137callHandoffOb
138 :: MonadObelisk m
139 => FilePath -- ^ Directory of the obelisk we want to handoff to
140 -> [String] -- ^ Arguments to pass to ob
141 -> m ()
142callHandoffOb dir args = do
143 obeliskCommandPkg <- nixCmd $ NixCmd_Build $ def
144 & nixBuildConfig_outLink .~ OutLink_None
145 & nixCmdConfig_target .~ Target
146 { _target_path = Just dir
147 , _target_attr = Just "command"
148 , _target_expr = Nothing
149 }
150 let impl = obeliskCommandPkg </> "bin" </> "ob"
151 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
152 putLog Debug $ "Running '" <> T.pack (unwords args) <> "' with " <> T.pack impl
153 callProcessAndLogOutput (Debug, Warning) (proc impl ("--no-handoff" : args))
155--TODO: Allow the user to ignore our security concerns
156-- | Find the Obelisk implementation for the project at the given path
157findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
158findProjectObeliskCommand target = do
159 myUid <- liftIO getRealUserID
160 processUmask <- liftIO getUmask
161 targetStat <- liftIO $ getFileStatus target
162 (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case
163 Nothing -> pure Nothing
164 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case
165 False -> do
166 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"
167 pure Nothing
168 True -> do
169 walkToImplDir projectRoot myUid processUmask -- For security check
170 return $ Just projectRoot
171 case (result, insecurePaths) of
172 (Just projDir, []) -> do
173 obeliskCommandPkg <- nixBuildAttrWithCache (toImplDir projDir) "command"
174 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
175 (Nothing, _) -> return Nothing
176 (Just projDir, _) -> do
177 putLog Error $ T.unlines
178 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
179 , T.unlines $ fmap (T.pack . normalise) insecurePaths
180 , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."
181 ]
182 return Nothing
184-- | Get the umask for the Obelisk process.
185--
186-- Because of
187-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the
188-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and
189-- reading isn't interrupted by any exception or interleaved with another thread.
190getUmask :: IO FileMode
191getUmask = withMVarMasked globalUmaskLock $ \() -> do
192 initialMask <- setFileCreationMask safeUmask
193 void (setFileCreationMask initialMask)
194 pure initialMask
195 where
196 safeUmask :: FileMode
197 safeUmask = CMode 0o22
199{-# NOINLINE globalUmaskLock #-}
200globalUmaskLock :: MVar ()
201globalUmaskLock = unsafePerformIO (newMVar ())
203-- | Get the FilePath to the containing project directory, if there is one
204findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
205findProjectRoot target = do
206 myUid <- liftIO getRealUserID
207 targetStat <- liftIO $ getFileStatus target
208 umask <- liftIO getUmask
209 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []
210 return $ makeRelative "." <$> result
212withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
213withProjectRoot target f = findProjectRoot target >>= \case
214 Nothing -> failWith "Must be used inside of an Obelisk project"
215 Just root -> f root
217-- | Walk from the current directory to the containing project's root directory,
218-- if there is one, accumulating potentially insecure directories that were
219-- traversed in the process. Return the project root directory, if found.
220walkToProjectRoot
221 :: (MonadState [FilePath] m, MonadIO m)
222 => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)
223walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case
224 -- It's not a directory, so it can't be a project
225 False -> do
226 let dir = takeDirectory this
227 dirStat <- liftIO $ getFileStatus dir
228 walkToProjectRoot dir dirStat desiredUmask myUid
229 True -> do
230 when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)
231 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case
232 True -> return $ Just this
233 False -> do
234 let next = this </> ".." -- Use ".." instead of chopping off path segments, so that if the current directory is moved during the traversal, the traversal stays consistent
235 nextStat <- liftIO $ getFileStatus next
236 let fileIdentity fs = (deviceID fs, fileID fs)
237 isSameFileAs = (==) `on` fileIdentity
238 if thisStat `isSameFileAs` nextStat
239 then return Nothing -- Found a cycle; probably hit root directory
240 else walkToProjectRoot next nextStat desiredUmask myUid
242-- | Walk from the given project root directory to its Obelisk implementation
243-- directory, accumulating potentially insecure directories that were traversed
244-- in the process.
245walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()
246walkToImplDir projectRoot myUid umask = do
247 let obDir = toObeliskDir projectRoot
248 obDirStat <- liftIO $ getFileStatus obDir
249 when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)
250 let implThunk = obDir </> "impl"
251 implThunkStat <- liftIO $ getFileStatus implThunk
252 when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)
254-- | Check to see if directory is writable by a user whose User ID matches the
255-- second argument provided, and if the fact that other people can write to that
256-- directory is in accordance with the umask of the system, passed as the third
257-- argument.
258isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool
259isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask
261isOwnedBy :: FileStatus -> UserID -> Bool
262isOwnedBy s uid = fileOwner s == uid
264-- | Check to see if a directory respect the umask, but check explicitly that
265-- it's not world writable in any case.
266filePermissionIsSafe :: FileStatus -> FileMode -> Bool
267filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable
268 where
269 fileWorldWritable = fileMode s .&. 0o002 == 0o002
270 fileGroupWritable = fileMode s .&. 0o020 == 0o020
271 umaskGroupWritable = umask .&. 0o020 == 0
273nixShellRunConfig :: MonadObelisk m => FilePath -> Bool -> Maybe String -> m NixShellConfig
274nixShellRunConfig root isPure command = do
275 nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $
276 proc nixExePath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]
277 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"
278 pure $ def
279 & nixShellConfig_pure .~ isPure
280 & nixShellConfig_common . nixCmdConfig_target .~ (def & target_path .~ Nothing)
281 & nixShellConfig_run .~ (command <&> \c -> mconcat
282 [ "export NIX_PATH=nixpkgs=", T.unpack nixpkgsPath, "; "
283 , maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote
284 , c
285 ])
287nixShellRunProc :: NixShellConfig -> ProcessSpec
288nixShellRunProc cfg = setDelegateCtlc True $ proc "nix-shell" $ runNixShellConfig cfg
290nixShellWithoutPkgs
291 :: MonadObelisk m
292 => FilePath -- ^ Path to project root
293 -> Bool -- ^ Should this be a pure shell?
294 -> Bool -- ^ Should we chdir to the package root in the shell?
295 -> Map Text FilePath -- ^ Package names mapped to their paths
296 -> String -- ^ Shell attribute to use (e.g. @"ghc"@, @"ghcjs"@, etc.)
297 -> Maybe String -- ^ If 'Just' run the given command; otherwise just open the interactive shell
298 -> m ()
299nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr command = do
300 packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute
301 defShellConfig <- nixShellRunConfig root isPure command
302 let setCwd_ = if chdirToRoot then setCwd (Just root) else id
303 (_, _, _, ph) <- createProcess_ "nixShellWithoutPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig
304 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~
305 "{root, pkgs, shell}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\
306 \shellPackages = builtins.fromJSON pkgs;\
307 \})).project.shells.${shell}"
308 & nixShellConfig_common . nixCmdConfig_args .~
309 [ rawArg "root" $ toNixPath $ if chdirToRoot then "." else root
310 , strArg "pkgs" (T.unpack $ decodeUtf8 $ BSL.toStrict $ Json.encode packageNamesAndAbsPaths)
311 , strArg "shell" shellAttr
312 ]
313 void $ waitForProcess ph
315nixShellWithHoogle :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
316nixShellWithHoogle root isPure shell' command = do
317 defShellConfig <- nixShellRunConfig root isPure command
318 (_, _, _, ph) <- createProcess_ "nixShellWithHoogle" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig
319 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~
320 "{shell}: ((import ./. {}).passthru.__unstable__.self.extend (_: super: {\
321 \userSettings = super.userSettings // { withHoogle = true; };\
322 \})).project.shells.${shell}"
323 & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ]
324 void $ waitForProcess ph
326findProjectAssets :: MonadObelisk m => FilePath -> m Text
327findProjectAssets root = do
328 isDerivation <- readProcessAndLogStderr Debug $ setCwd (Just root) $
329 proc nixExePath
330 [ "eval"
331 , "(let a = import ./. {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
332 , "--raw"
333 -- `--raw` is not available with old nix-instantiate. It drops quotation
334 -- marks and trailing newline, so is very convenient for shelling out.
335 ]
336 -- Check whether the impure static files are a derivation (and so must be built)
337 if isDerivation == "1"
338 then fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ -- Strip whitespace here because nix-build has no --raw option
339 proc nixBuildExePath
340 [ "--no-out-link"
341 , "-E", "(import ./. {}).passthru.staticFilesImpure"
342 ]
343 else readProcessAndLogStderr Debug $ setCwd (Just root) $
344 proc nixExePath ["eval", "-f", ".", "passthru.staticFilesImpure", "--raw"]