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