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