git.iko.soy/obelisk
on ee81335 help sign in
obelisk/lib/command/src/Obelisk/Command/Project.hs
217 lines 8.8 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Obelisk.Command.Project
5 ( InitSource (..)
6 , initProject
7 , findProjectObeliskCommand
8 , findProjectRoot
9 , withProjectRoot
10 , inProjectShell
11 , inImpureProjectShell
12 , projectShell
14 , toObeliskDir
15 , toImplDir
16 ) where
18import Control.Monad
19import Control.Monad.IO.Class (liftIO)
20import Control.Monad.State
21import Data.Bits
22import Data.Function (on)
23import qualified Data.Text as T
24import System.Directory
25import System.FilePath
26import System.IO.Temp
27import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
28import System.Posix.Files
29import System.Process (CreateProcess, cwd, proc, waitForProcess)
31import GitHub.Data.GitData (Branch)
32import GitHub.Data.Name (Name)
34import Obelisk.App (MonadObelisk)
35import Obelisk.CliApp
36import Obelisk.Command.Thunk
37import Obelisk.Command.Nix (withNixRemoteCheck)
38--TODO: Make this module resilient to random exceptions
40--TODO: Don't hardcode this
41-- | Source for the Obelisk project
42obeliskSource :: ThunkSource
43obeliskSource = obeliskSourceWithBranch "master"
45-- | Source for obelisk developer targeting a specific obelisk branch
46obeliskSourceWithBranch :: Name Branch -> ThunkSource
47obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource
48 { _gitHubSource_owner = "obsidiansystems"
49 , _gitHubSource_repo = "obelisk"
50 , _gitHubSource_branch = Just branch
51 }
53data InitSource
54 = InitSource_Default
55 | InitSource_Branch (Name Branch)
56 | InitSource_Symlink FilePath
57 deriving Show
59-- | Path to obelisk directory in given path
60toObeliskDir :: FilePath -> FilePath
61toObeliskDir p = p </> ".obelisk"
63-- | Path to impl file in given path
64toImplDir :: FilePath -> FilePath
65toImplDir p = toObeliskDir p </> "impl"
67-- | Create a new project rooted in the current directory
68initProject :: MonadObelisk m => InitSource -> Bool -> m ()
69initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do
70 let implDir = toImplDir tmpDir
71 obDir = toObeliskDir tmpDir
72 liftIO (listDirectory ".") >>= \case
73 [] -> pure ()
74 _ | force -> putLog Warning "Initializing in non-empty directory"
75 | otherwise -> failWith "ob init requires an empty directory. Use the flag --force to init anyway, potentially overwriting files."
76 skeleton <- withSpinner "Setting up obelisk" $ do
77 liftIO $ createDirectory obDir
78 case source of
79 InitSource_Default -> createThunkWithLatest implDir obeliskSource
80 InitSource_Branch branch -> createThunkWithLatest implDir $ obeliskSourceWithBranch branch
81 InitSource_Symlink path -> do
82 let symlinkPath = if isAbsolute path
83 then path
84 else ".." </> path
85 liftIO $ createSymbolicLink symlinkPath implDir
86 _ <- nixBuildAttrWithCache implDir "command"
87 --TODO: We should probably handoff to the impl here
88 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
90 callProcessAndLogOutput (Notice, Error) $
91 proc "cp"
92 [ "-r"
93 , "--preserve=links"
94 , obDir
95 , toObeliskDir "."
96 ]
97 pure skel
99 withSpinner "Copying project skeleton" $ do
100 callProcessAndLogOutput (Notice, Error) $
101 proc "cp"
102 [ "-r"
103 , "--no-preserve=mode"
104 , "-T"
105 , skeleton </> "."
106 , "."
107 ]
108 liftIO $ do
109 let configDir = "config"
110 createDirectoryIfMissing False configDir
111 mapM_ (createDirectoryIfMissing False . (configDir </>)) ["backend", "common", "frontend"]
113--TODO: Allow the user to ignore our security concerns
114-- | Find the Obelisk implementation for the project at the given path
115findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
116findProjectObeliskCommand target = do
117 myUid <- liftIO getRealUserID
118 targetStat <- liftIO $ getFileStatus target
119 (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case
120 Nothing -> pure Nothing
121 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case
122 False -> do
123 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"
124 pure Nothing
125 True -> do
126 walkToImplDir projectRoot myUid -- For security check
127 return $ Just projectRoot
128 case (result, insecurePaths) of
129 (Just projDir, []) -> do
130 obeliskCommandPkg <- nixBuildAttrWithCache (toImplDir projDir) "command"
131 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
132 (Nothing, _) -> return Nothing
133 (Just projDir, _) -> do
134 putLog Error $ T.unlines
135 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
136 , T.unlines $ fmap (T.pack . normalise) insecurePaths
137 , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
138 ]
139 return Nothing
141-- | Get the FilePath to the containing project directory, if there is one
142findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
143findProjectRoot target = do
144 myUid <- liftIO getRealUserID
145 targetStat <- liftIO $ getFileStatus target
146 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []
147 return result
149withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m ()) -> m ()
150withProjectRoot target f = findProjectRoot target >>= \case
151 Nothing -> failWith "Must be used inside of an Obelisk project"
152 Just root -> f root
154-- | Walk from the current directory to the containing project's root directory,
155-- if there is one, accumulating potentially insecure directories that were
156-- traversed in the process. Return the project root directory, if found.
157walkToProjectRoot
158 :: (MonadState [FilePath] m, MonadIO m)
159 => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)
160walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case
161 -- It's not a directory, so it can't be a project
162 False -> do
163 let dir = takeDirectory this
164 dirStat <- liftIO $ getFileStatus dir
165 walkToProjectRoot dir dirStat myUid
166 True -> do
167 when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)
168 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case
169 True -> return $ Just this
170 False -> do
171 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
172 nextStat <- liftIO $ getFileStatus next
173 let fileIdentity fs = (deviceID fs, fileID fs)
174 isSameFileAs = (==) `on` fileIdentity
175 if thisStat `isSameFileAs` nextStat
176 then return Nothing -- Found a cycle; probably hit root directory
177 else walkToProjectRoot next nextStat myUid
179-- | Walk from the given project root directory to its Obelisk implementation
180-- directory, accumulating potentially insecure directories that were traversed
181-- in the process.
182walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()
183walkToImplDir projectRoot myUid = do
184 let obDir = toObeliskDir projectRoot
185 obDirStat <- liftIO $ getFileStatus obDir
186 when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)
187 let implThunk = obDir </> "impl"
188 implThunkStat <- liftIO $ getFileStatus implThunk
189 when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)
191--TODO: Is there a better way to ask if anyone else can write things?
192--E.g. what about ACLs?
193-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided
194isWritableOnlyBy :: FileStatus -> UserID -> Bool
195isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0
197-- | Run a command in the given shell for the current project
198inProjectShell :: MonadObelisk m => String -> String -> m ()
199inProjectShell shellName command = withProjectRoot "." $ \root ->
200 projectShell root True shellName command
202inImpureProjectShell :: MonadObelisk m => String -> String -> m ()
203inImpureProjectShell shellName command = withProjectRoot "." $ \root ->
204 projectShell root False shellName command
206projectShell :: MonadObelisk m => FilePath -> Bool -> String -> String -> m ()
207projectShell root isPure shellName command = withNixRemoteCheck $ do
208 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCwd (Just root) $ proc "nix-shell" $
209 [ "--pure" | isPure ] <>
210 [ "-A"
211 , "shells." <> shellName
212 , "--run", command
213 ]
214 void $ liftIO $ waitForProcess ph
216setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess
217setCwd fp cfg = cfg { cwd = fp }