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