git.iko.soy/obelisk
on 63c7b21 help sign in
obelisk/lib/command/src/Obelisk/Command/Project.hs
216 lines 8.7 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
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 command
201inImpureProjectShell :: MonadObelisk m => String -> String -> m ()
202inImpureProjectShell shellName command = withProjectRoot "." $ \root ->
203 projectShell root False shellName command
205projectShell :: MonadObelisk m => FilePath -> Bool -> String -> String -> m ()
206projectShell root isPure shellName command = do
207 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCwd (Just root) $ proc "nix-shell" $
208 [ "--pure" | isPure ] <>
209 [ "-A"
210 , "shells." <> shellName
211 , "--run", command
212 ]
213 void $ liftIO $ waitForProcess ph
215setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess
216setCwd fp cfg = cfg { cwd = fp }