git.iko.soy/obelisk
on ba85ebf help sign in
obelisk/lib/command/src/Obelisk/Command/Project.hs
330 lines 14 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 , nixShellWithPkgs
14 , obeliskDirName
15 , projectShell
16 , toImplDir
17 , toNixPath
18 , toObeliskDir
19 , withProjectRoot
20 ) where
22import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
23import Control.Lens ((.~), (?~), (<&>))
24import Control.Monad
25import Control.Monad.IO.Class (liftIO)
26import Control.Monad.State
27import qualified Data.Aeson as Json
28import Data.Bits
29import qualified Data.ByteString.Lazy as BSL
30import Data.Default (def)
31import Data.Function ((&), on)
32import Data.List (isInfixOf)
33import Data.Map (Map)
34import Data.Text (Text)
35import qualified Data.Text as T
36import Data.Text.Encoding (decodeUtf8)
37import Data.Traversable (for)
38import System.Directory
39import System.Environment (lookupEnv)
40import System.FilePath
41import System.IO.Temp
42import System.IO.Unsafe (unsafePerformIO)
43import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
44import System.Posix.Files
45import System.Process (waitForProcess)
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 (nixExePath, nixBuildExePath)
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 case source of
101 InitSource_Default -> createThunkWithLatest implDir obeliskSource
102 InitSource_Branch branch -> createThunkWithLatest implDir $ obeliskSourceWithBranch branch
103 InitSource_Symlink path -> do
104 let symlinkPath = if isAbsolute path
105 then path
106 else ".." </> path
107 liftIO $ createSymbolicLink symlinkPath implDir
108 _ <- nixBuildAttrWithCache implDir "command"
109 --TODO: We should probably handoff to the impl here
110 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
112 callProcessAndLogOutput (Notice, Error) $
113 proc "cp"
114 [ "-r"
115 , "--preserve=links"
116 , obDir
117 , toObeliskDir "."
118 ]
119 pure skel
121 withSpinner "Copying project skeleton" $ do
122 callProcessAndLogOutput (Notice, Error) $
123 proc "cp"
124 [ "-r"
125 , "--no-preserve=mode"
126 , "-T"
127 , skeleton </> "."
128 , "."
129 ]
130 liftIO $ do
131 let configDir = "config"
132 createDirectoryIfMissing False configDir
133 mapM_ (createDirectoryIfMissing False . (configDir </>)) ["backend", "common", "frontend"]
135--TODO: Allow the user to ignore our security concerns
136-- | Find the Obelisk implementation for the project at the given path
137findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
138findProjectObeliskCommand target = do
139 myUid <- liftIO getRealUserID
140 processUmask <- liftIO getUmask
141 targetStat <- liftIO $ getFileStatus target
142 (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case
143 Nothing -> pure Nothing
144 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case
145 False -> do
146 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"
147 pure Nothing
148 True -> do
149 walkToImplDir projectRoot myUid processUmask -- For security check
150 return $ Just projectRoot
151 case (result, insecurePaths) of
152 (Just projDir, []) -> do
153 obeliskCommandPkg <- nixBuildAttrWithCache (toImplDir projDir) "command"
154 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
155 (Nothing, _) -> return Nothing
156 (Just projDir, _) -> do
157 putLog Error $ T.unlines
158 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
159 , T.unlines $ fmap (T.pack . normalise) insecurePaths
160 , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."
161 ]
162 return Nothing
164-- | Get the umask for the Obelisk process.
165--
166-- Because of
167-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the
168-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and
169-- reading isn't interrupted by any exception or interleaved with another thread.
170getUmask :: IO FileMode
171getUmask = withMVarMasked globalUmaskLock $ \() -> do
172 initialMask <- setFileCreationMask safeUmask
173 void (setFileCreationMask initialMask)
174 pure initialMask
175 where
176 safeUmask :: FileMode
177 safeUmask = CMode 0o22
179{-# NOINLINE globalUmaskLock #-}
180globalUmaskLock :: MVar ()
181globalUmaskLock = unsafePerformIO (newMVar ())
183-- | Get the FilePath to the containing project directory, if there is one
184findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
185findProjectRoot target = do
186 myUid <- liftIO getRealUserID
187 targetStat <- liftIO $ getFileStatus target
188 umask <- liftIO getUmask
189 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []
190 return $ makeRelative "." <$> result
192withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
193withProjectRoot target f = findProjectRoot target >>= \case
194 Nothing -> failWith "Must be used inside of an Obelisk project"
195 Just root -> f root
197-- | Walk from the current directory to the containing project's root directory,
198-- if there is one, accumulating potentially insecure directories that were
199-- traversed in the process. Return the project root directory, if found.
200walkToProjectRoot
201 :: (MonadState [FilePath] m, MonadIO m)
202 => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)
203walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case
204 -- It's not a directory, so it can't be a project
205 False -> do
206 let dir = takeDirectory this
207 dirStat <- liftIO $ getFileStatus dir
208 walkToProjectRoot dir dirStat desiredUmask myUid
209 True -> do
210 when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)
211 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case
212 True -> return $ Just this
213 False -> do
214 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
215 nextStat <- liftIO $ getFileStatus next
216 let fileIdentity fs = (deviceID fs, fileID fs)
217 isSameFileAs = (==) `on` fileIdentity
218 if thisStat `isSameFileAs` nextStat
219 then return Nothing -- Found a cycle; probably hit root directory
220 else walkToProjectRoot next nextStat desiredUmask myUid
222-- | Walk from the given project root directory to its Obelisk implementation
223-- directory, accumulating potentially insecure directories that were traversed
224-- in the process.
225walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()
226walkToImplDir projectRoot myUid umask = do
227 let obDir = toObeliskDir projectRoot
228 obDirStat <- liftIO $ getFileStatus obDir
229 when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)
230 let implThunk = obDir </> "impl"
231 implThunkStat <- liftIO $ getFileStatus implThunk
232 when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)
234-- | Check to see if directory is writable by a user whose User ID matches the
235-- second argument provided, and if the fact that other people can write to that
236-- directory is in accordance with the umask of the system, passed as the third
237-- argument.
238isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool
239isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask
241isOwnedBy :: FileStatus -> UserID -> Bool
242isOwnedBy s uid = fileOwner s == uid
244-- | Check to see if a directory respect the umask, but check explicitly that
245-- it's not world writable in any case.
246filePermissionIsSafe :: FileStatus -> FileMode -> Bool
247filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable
248 where
249 fileWorldWritable = fileMode s .&. 0o002 == 0o002
250 fileGroupWritable = fileMode s .&. 0o020 == 0o020
251 umaskGroupWritable = umask .&. 0o020 == 0
253-- | Nix syntax requires relative paths to be prefixed by @./@ or
254-- @../@. This will make a 'FilePath' that can be embedded in a Nix
255-- expression.
256toNixPath :: FilePath -> FilePath
257toNixPath root | "/" `isInfixOf` root = root
258 | otherwise = "./" <> root
260nixShellRunConfig :: MonadObelisk m => FilePath -> Bool -> Maybe String -> m NixShellConfig
261nixShellRunConfig root isPure command = do
262 nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $
263 proc nixExePath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]
264 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"
265 pure $ def
266 & nixShellConfig_pure .~ isPure
267 & nixShellConfig_common . nixCmdConfig_target .~ (def & target_path .~ Nothing)
268 & nixShellConfig_run .~ (command <&> \c -> mconcat
269 [ "export NIX_PATH=nixpkgs=", T.unpack nixpkgsPath, "; "
270 , maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote
271 , c
272 ])
274nixShellRunProc :: NixShellConfig -> ProcessSpec
275nixShellRunProc cfg = setDelegateCtlc True $ proc "nix-shell" $ runNixShellConfig cfg
277nixShellWithPkgs :: MonadObelisk m => FilePath -> Bool -> Bool -> Map Text FilePath -> Maybe String -> m ()
278nixShellWithPkgs root isPure chdirToRoot packageNamesAndPaths command = do
279 packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute
280 defShellConfig <- nixShellRunConfig root isPure command
281 let setCwd_ = if chdirToRoot then setCwd (Just root) else id
282 (_, _, _, ph) <- createProcess_ "nixShellWithPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig
283 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~
284 "{root, pkgs}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\
285 \shellPackages = builtins.fromJSON pkgs;\
286 \})).project.shells.ghc"
287 & nixShellConfig_common . nixCmdConfig_args .~
288 [ rawArg "root" $ toNixPath $ if chdirToRoot then "." else root
289 , strArg "pkgs" (T.unpack $ decodeUtf8 $ BSL.toStrict $ Json.encode packageNamesAndAbsPaths)
290 ]
291 void $ liftIO $ waitForProcess ph
293nixShellWithHoogle :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
294nixShellWithHoogle root isPure shell' command = do
295 defShellConfig <- nixShellRunConfig root isPure command
296 (_, _, _, ph) <- createProcess_ "nixShellWithHoogle" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig
297 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~
298 "{shell}: ((import ./. {}).passthru.__unstable__.self.extend (_: super: {\
299 \userSettings = super.userSettings // { withHoogle = true; };\
300 \})).project.shells.${shell}"
301 & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ]
302 void $ liftIO $ waitForProcess ph
304projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
305projectShell root isPure shellName command = do
306 defShellConfig <- nixShellRunConfig root isPure command
307 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig
308 & nixShellConfig_common . nixCmdConfig_target . target_path ?~ "default.nix"
309 & nixShellConfig_common . nixCmdConfig_target . target_attr ?~ ("shells." <> shellName)
310 void $ liftIO $ waitForProcess ph
312findProjectAssets :: MonadObelisk m => FilePath -> m Text
313findProjectAssets root = do
314 isDerivation <- readProcessAndLogStderr Debug $ setCwd (Just root) $
315 proc nixExePath
316 [ "eval"
317 , "(let a = import ./. {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
318 , "--raw"
319 -- `--raw` is not available with old nix-instantiate. It drops quotation
320 -- marks and trailing newline, so is very convenient for shelling out.
321 ]
322 -- Check whether the impure static files are a derivation (and so must be built)
323 if isDerivation == "1"
324 then fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ -- Strip whitespace here because nix-build has no --raw option
325 proc nixBuildExePath
326 [ "--no-out-link"
327 , "-E", "(import ./. {}).passthru.staticFilesImpure"
328 ]
329 else readProcessAndLogStderr Debug $ setCwd (Just root) $
330 proc nixExePath ["eval", "-f", ".", "passthru.staticFilesImpure", "--raw"]