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