git.iko.soy/obelisk
on 66e7444 help sign in
obelisk/lib/command/src/Obelisk/Command/Project.hs
270 lines 11 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TemplateHaskell #-}
5module Obelisk.Command.Project
6 ( InitSource (..)
7 , initProject
8 , findProjectObeliskCommand
9 , findProjectRoot
10 , withProjectRoot
11 , inProjectShell
12 , inImpureProjectShell
13 , projectShell
15 , toObeliskDir
16 , toImplDir
17 ) where
19import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
20import Control.Monad
21import Control.Monad.IO.Class (liftIO)
22import Control.Monad.State
23import Data.Bits
24import Data.Function (on)
25import qualified Data.Text as T
26import System.Directory
27import System.Environment (lookupEnv)
28import System.FilePath
29import System.IO.Temp
30import System.IO.Unsafe (unsafePerformIO)
31import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
32import System.Posix.Files
33import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)
34import System.Which (staticWhich)
36import GitHub.Data.GitData (Branch)
37import GitHub.Data.Name (Name)
39import Obelisk.App (MonadObelisk)
40import Obelisk.CliApp
41import Obelisk.Command.Thunk
43--TODO: Make this module resilient to random exceptions
45--TODO: Don't hardcode this
46-- | Source for the Obelisk project
47obeliskSource :: ThunkSource
48obeliskSource = obeliskSourceWithBranch "master"
50-- | Source for obelisk developer targeting a specific obelisk branch
51obeliskSourceWithBranch :: Name Branch -> ThunkSource
52obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource
53 { _gitHubSource_owner = "obsidiansystems"
54 , _gitHubSource_repo = "obelisk"
55 , _gitHubSource_branch = Just branch
56 }
58data InitSource
59 = InitSource_Default
60 | InitSource_Branch (Name Branch)
61 | InitSource_Symlink FilePath
62 deriving Show
64-- | Path to obelisk directory in given path
65toObeliskDir :: FilePath -> FilePath
66toObeliskDir p = p </> ".obelisk"
68-- | Path to impl file in given path
69toImplDir :: FilePath -> FilePath
70toImplDir p = toObeliskDir p </> "impl"
72-- | Create a new project rooted in the current directory
73initProject :: MonadObelisk m => InitSource -> Bool -> m ()
74initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do
75 let implDir = toImplDir tmpDir
76 obDir = toObeliskDir tmpDir
77 liftIO (listDirectory ".") >>= \case
78 [] -> pure ()
79 _ | force -> putLog Warning "Initializing in non-empty directory"
80 | otherwise -> failWith "ob init requires an empty directory. Use the flag --force to init anyway, potentially overwriting files."
81 skeleton <- withSpinner "Setting up obelisk" $ do
82 liftIO $ createDirectory obDir
83 case source of
84 InitSource_Default -> createThunkWithLatest implDir obeliskSource
85 InitSource_Branch branch -> createThunkWithLatest implDir $ obeliskSourceWithBranch branch
86 InitSource_Symlink path -> do
87 let symlinkPath = if isAbsolute path
88 then path
89 else ".." </> path
90 liftIO $ createSymbolicLink symlinkPath implDir
91 _ <- nixBuildAttrWithCache implDir "command"
92 --TODO: We should probably handoff to the impl here
93 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
95 callProcessAndLogOutput (Notice, Error) $
96 proc "cp"
97 [ "-r"
98 , "--preserve=links"
99 , obDir
100 , toObeliskDir "."
101 ]
102 pure skel
104 withSpinner "Copying project skeleton" $ do
105 callProcessAndLogOutput (Notice, Error) $
106 proc "cp"
107 [ "-r"
108 , "--no-preserve=mode"
109 , "-T"
110 , skeleton </> "."
111 , "."
112 ]
113 liftIO $ do
114 let configDir = "config"
115 createDirectoryIfMissing False configDir
116 mapM_ (createDirectoryIfMissing False . (configDir </>)) ["backend", "common", "frontend"]
118--TODO: Allow the user to ignore our security concerns
119-- | Find the Obelisk implementation for the project at the given path
120findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
121findProjectObeliskCommand target = do
122 myUid <- liftIO getRealUserID
123 processUmask <- liftIO getUmask
124 targetStat <- liftIO $ getFileStatus target
125 (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case
126 Nothing -> pure Nothing
127 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case
128 False -> do
129 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"
130 pure Nothing
131 True -> do
132 walkToImplDir projectRoot myUid processUmask -- For security check
133 return $ Just projectRoot
134 case (result, insecurePaths) of
135 (Just projDir, []) -> do
136 obeliskCommandPkg <- nixBuildAttrWithCache (toImplDir projDir) "command"
137 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
138 (Nothing, _) -> return Nothing
139 (Just projDir, _) -> do
140 putLog Error $ T.unlines
141 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
142 , T.unlines $ fmap (T.pack . normalise) insecurePaths
143 , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."
144 ]
145 return Nothing
147-- | Get the umask for the Obelisk process.
148--
149-- Because of
150-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the
151-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and
152-- reading isn't interrupted by any exception or interleaved with another thread.
153getUmask :: IO FileMode
154getUmask = withMVarMasked globalUmaskLock $ \() -> do
155 initialMask <- setFileCreationMask safeUmask
156 void (setFileCreationMask initialMask)
157 pure initialMask
158 where
159 safeUmask :: FileMode
160 safeUmask = CMode 0o22
162{-# NOINLINE globalUmaskLock #-}
163globalUmaskLock :: MVar ()
164globalUmaskLock = unsafePerformIO (newMVar ())
166-- | Get the FilePath to the containing project directory, if there is one
167findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
168findProjectRoot target = do
169 myUid <- liftIO getRealUserID
170 targetStat <- liftIO $ getFileStatus target
171 umask <- liftIO $ getUmask
172 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []
173 return result
175withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
176withProjectRoot target f = findProjectRoot target >>= \case
177 Nothing -> failWith "Must be used inside of an Obelisk project"
178 Just root -> f root
180-- | Walk from the current directory to the containing project's root directory,
181-- if there is one, accumulating potentially insecure directories that were
182-- traversed in the process. Return the project root directory, if found.
183walkToProjectRoot
184 :: (MonadState [FilePath] m, MonadIO m)
185 => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)
186walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case
187 -- It's not a directory, so it can't be a project
188 False -> do
189 let dir = takeDirectory this
190 dirStat <- liftIO $ getFileStatus dir
191 walkToProjectRoot dir dirStat desiredUmask myUid
192 True -> do
193 when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)
194 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case
195 True -> return $ Just this
196 False -> do
197 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
198 nextStat <- liftIO $ getFileStatus next
199 let fileIdentity fs = (deviceID fs, fileID fs)
200 isSameFileAs = (==) `on` fileIdentity
201 if thisStat `isSameFileAs` nextStat
202 then return Nothing -- Found a cycle; probably hit root directory
203 else walkToProjectRoot next nextStat desiredUmask myUid
205-- | Walk from the given project root directory to its Obelisk implementation
206-- directory, accumulating potentially insecure directories that were traversed
207-- in the process.
208walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()
209walkToImplDir projectRoot myUid umask = do
210 let obDir = toObeliskDir projectRoot
211 obDirStat <- liftIO $ getFileStatus obDir
212 when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)
213 let implThunk = obDir </> "impl"
214 implThunkStat <- liftIO $ getFileStatus implThunk
215 when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)
217-- | Check to see if directory is writable by a user whose User ID matches the
218-- second argument provided, and if the fact that other people can write to that
219-- directory is in accordance with the umask of the system, passed as the third
220-- argument.
221isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool
222isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask
224isOwnedBy :: FileStatus -> UserID -> Bool
225isOwnedBy s uid = fileOwner s == uid
227-- | Check to see if a directory respect the umask, but check explicitly that
228-- it's not world writable in any case.
229filePermissionIsSafe :: FileStatus -> FileMode -> Bool
230filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable
231 where
232 fileWorldWritable = fileMode s .&. 0o002 == 0o002
233 fileGroupWritable = fileMode s .&. 0o020 == 0o020
234 umaskGroupWritable = umask .&. 0o020 == 0
236-- | Run a command in the given shell for the current project
237inProjectShell :: MonadObelisk m => String -> String -> m ()
238inProjectShell shellName command = withProjectRoot "." $ \root ->
239 projectShell root True shellName (Just command)
241inImpureProjectShell :: MonadObelisk m => String -> String -> m ()
242inImpureProjectShell shellName command = withProjectRoot "." $ \root ->
243 projectShell root False shellName (Just command)
245projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
246projectShell root isPure shellName command = do
247 let nixPath = $(staticWhich "nix")
248 nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]
249 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"
250 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $
251 [ "default.nix"] <>
252 ["--pure" | isPure] <>
253 [ "-A"
254 , "shells." <> shellName
255 ] <> case command of
256 Nothing -> []
257 Just c ->
258 -- TODO: Escape nixpkgsPath and nixRemote
259 [ "--run"
260 , "export NIX_PATH=nixpkgs=" <> T.unpack nixpkgsPath <> "; " <>
261 maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote <>
262 c
263 ]
264 void $ liftIO $ waitForProcess ph
266setCtlc :: CreateProcess -> CreateProcess
267setCtlc cfg = cfg { delegate_ctlc = True }
269setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess
270setCwd fp cfg = cfg { cwd = fp }