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