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