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