git.iko.soy/obelisk
on master help sign in
Make it possible to build non-thunks, e.g. for impl
c565d49Ryan Trinkle
command/obelisk-command.cabal+4−1
compare with master
unifiedsplit
@@ -11,10 +11,12 @@ library
11 , base
11 , base
12 , bytestring
12 , bytestring
13 , containers
13 , containers
14+ , data-default
14 , directory
15 , directory
15 , filepath
16 , filepath
16 , github
17 , github
17 , hit
18 , hit
19+ , mtl
18 , network-uri
20 , network-uri
19 , optparse-applicative
21 , optparse-applicative
20 , process
22 , process
@@ -25,9 +27,10 @@ library
25 , yaml
27 , yaml
26 exposed-modules:
28 exposed-modules:
27 Obelisk.Command
29 Obelisk.Command
30+ Obelisk.Command.Nix
28 Obelisk.Command.Project
31 Obelisk.Command.Project
29− Obelisk.Command.Thunk
30 Obelisk.Command.Repl
32 Obelisk.Command.Repl
33+ Obelisk.Command.Thunk
31 ghc-options: -Wall
34 ghc-options: -Wall
32
35
33executable ob
36executable ob
command/src/Obelisk/Command/Nix.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE LambdaCase #-}
2+module Obelisk.Command.Nix
3+ ( nixBuild
4+ , NixBuildConfig (..)
5+ , Target (..)
6+ , OutLink (..)
7+ ) where
8+
9+import qualified Data.ByteString.Lazy as LBS
10+import Data.Default
11+import qualified Data.Text as T
12+import qualified Data.Text.IO as T
13+import System.Exit
14+import System.Process
15+
16+-- | Where to put nix-build output
17+data OutLink
18+ = OutLink_Default
19+ | OutLink_None
20+ | OutLink_IndirectRoot FilePath
21+
22+instance Default OutLink where
23+ def = OutLink_Default
24+
25+-- | What to build
26+data Target = Target
27+ { _target_path :: FilePath
28+ , _target_attr :: Maybe String
29+ }
30+
31+instance Default Target where
32+ def = Target
33+ { _target_path = "."
34+ , _target_attr = Nothing
35+ }
36+
37+data NixBuildConfig = NixBuildConfig
38+ { _nixBuildConfig_target :: Target
39+ , _nixBuildConfig_outLink :: OutLink
40+ }
41+
42+instance Default NixBuildConfig where
43+ def = NixBuildConfig def def
44+
45+nixBuild :: NixBuildConfig -> IO FilePath
46+nixBuild cfg = do
47+ let args = mconcat
48+ [ [_target_path $ _nixBuildConfig_target cfg]
49+ , case _target_attr $ _nixBuildConfig_target cfg of
50+ Nothing -> []
51+ Just attr -> ["-A", attr]
52+ , case _nixBuildConfig_outLink cfg of
53+ OutLink_Default -> []
54+ OutLink_None -> ["--no-out-link"]
55+ OutLink_IndirectRoot outLink -> ["--indirect", "--add-root", outLink]
56+ ]
57+ (_, out, err, p) <- runInteractiveProcess "nix-build" args Nothing Nothing
58+ waitForProcess p >>= \case
59+ ExitSuccess -> return ()
60+ _ -> do
61+ LBS.putStr =<< LBS.hGetContents err
62+ fail "nix-build failed"
63+ T.unpack . T.strip <$> T.hGetContents out
command/src/Obelisk/Command/Project.hs+3−3
@@ -49,9 +49,9 @@ initProject target branch = do
49 implDir = obDir </> "impl"
49 implDir = obDir </> "impl"
50 createDirectory obDir
50 createDirectory obDir
51 createThunkWithLatest implDir $ maybe obeliskSource obeliskSourceWithBranch branch
51 createThunkWithLatest implDir $ maybe obeliskSource obeliskSourceWithBranch branch
52− _ <- nixBuildThunkAttrWithCache implDir "command"
52+ _ <- nixBuildAttrWithCache implDir "command"
53 --TODO: We should probably handoff to the impl here
53 --TODO: We should probably handoff to the impl here
54− skeleton <- nixBuildThunkAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
54+ skeleton <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
55 (_, _, _, p) <- runInteractiveProcess "cp" --TODO: Make this package depend on nix-prefetch-url properly
55 (_, _, _, p) <- runInteractiveProcess "cp" --TODO: Make this package depend on nix-prefetch-url properly
56 [ "-r"
56 [ "-r"
57 , "--no-preserve=mode"
57 , "--no-preserve=mode"
@@ -85,7 +85,7 @@ findProjectObeliskCommand target = do
85 return $ Just projectRoot
85 return $ Just projectRoot
86 case (result, insecurePaths) of
86 case (result, insecurePaths) of
87 (Just projDir, []) -> do
87 (Just projDir, []) -> do
88− obeliskCommandPkg <- nixBuildThunkAttrWithCache (projDir </> ".obelisk" </> "impl") "command"
88+ obeliskCommandPkg <- nixBuildAttrWithCache (projDir </> ".obelisk" </> "impl") "command"
89 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
89 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
90 (Nothing, _) -> return Nothing
90 (Nothing, _) -> return Nothing
91 (Just projDir, _) -> do
91 (Just projDir, _) -> do
command/src/Obelisk/Command/Thunk.hs+50−22
@@ -9,14 +9,16 @@ module Obelisk.Command.Thunk
9 , getLatestRev
9 , getLatestRev
10 , updateThunkToLatest
10 , updateThunkToLatest
11 , createThunkWithLatest
11 , createThunkWithLatest
12− , nixBuildThunkAttrWithCache
12+ , nixBuildAttrWithCache
13 ) where
13 ) where
14
14
15import Control.Exception
15import Control.Exception
16import Control.Monad
16import Control.Monad
17+import Control.Monad.Except
17import Data.Aeson as Aeson
18import Data.Aeson as Aeson
18import Data.Aeson.Encode.Pretty
19import Data.Aeson.Encode.Pretty
19import qualified Data.ByteString.Lazy as LBS
20import qualified Data.ByteString.Lazy as LBS
21+import Data.Default
20import Data.Foldable
22import Data.Foldable
21import Data.Git.Ref (Ref)
23import Data.Git.Ref (Ref)
22import qualified Data.Git.Ref as Ref
24import qualified Data.Git.Ref as Ref
@@ -24,6 +26,7 @@ import Data.List.NonEmpty (NonEmpty (..))
24import qualified Data.List.NonEmpty as NonEmpty
26import qualified Data.List.NonEmpty as NonEmpty
25import Data.Maybe
27import Data.Maybe
26import Data.Monoid
28import Data.Monoid
29+import Data.Set (Set)
27import qualified Data.Set as Set
30import qualified Data.Set as Set
28import Data.Text (Text)
31import Data.Text (Text)
29import qualified Data.Text as T
32import qualified Data.Text as T
@@ -36,6 +39,7 @@ import GitHub
36import GitHub.Endpoints.Repos.Contents (archiveForR)
39import GitHub.Endpoints.Repos.Contents (archiveForR)
37import GitHub.Data.Name
40import GitHub.Data.Name
38import Network.URI
41import Network.URI
42+import Obelisk.Command.Nix
39import System.Directory
43import System.Directory
40import System.Exit
44import System.Exit
41import System.FilePath
45import System.FilePath
@@ -109,10 +113,15 @@ getLatestRev = \case
109 , _thunkRev_nixSha256 = nixSha256
113 , _thunkRev_nixSha256 = nixSha256
110 }
114 }
111
115
116+data ReadThunkError
117+ = ReadThunkError_WrongContents (Set String) (Set String)
118+ | ReadThunkError_UnrecognizedLoader Text
119+ | ReadThunkError_UnparseablePtr LBS.ByteString
120+
112-- | Read a thunk and validate that it is only a thunk. If additional data is
121-- | Read a thunk and validate that it is only a thunk. If additional data is
113-- present, fail.
122-- present, fail.
114−readThunk :: FilePath -> IO (Maybe ThunkPtr)
123+readThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
115−readThunk thunkDir = do
124+readThunk thunkDir = runExceptT $ do
116 let thunkLoader = thunkDir </> "default.nix"
125 let thunkLoader = thunkDir </> "default.nix"
117 githubJson = thunkDir </> "github.json"
126 githubJson = thunkDir </> "github.json"
118 attrCache = thunkDir </> ".attr-cache"
127 attrCache = thunkDir </> ".attr-cache"
@@ -124,16 +133,18 @@ readThunk thunkDir = do
124
133
125 -- Ensure that there aren't any other files in the thunk
134 -- Ensure that there aren't any other files in the thunk
126 -- NB: System.Directory.listDirectory returns the contents without the directory path
135 -- NB: System.Directory.listDirectory returns the contents without the directory path
127− files <- Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
136+ files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
128 let unexpectedContents = files `Set.difference` expectedContents
137 let unexpectedContents = files `Set.difference` expectedContents
129 missingContents = expectedContents `Set.difference` files
138 missingContents = expectedContents `Set.difference` files
130− guard $ Set.null unexpectedContents && Set.null missingContents
139+ unless (Set.null unexpectedContents && Set.null missingContents) $ do
140+ throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
131
141
132 -- Ensure that we recognize the thunk loader
142 -- Ensure that we recognize the thunk loader
133− loader <- T.readFile thunkLoader
143+ loader <- liftIO $ T.readFile thunkLoader
134− guard $ loader `elem` gitHubStandaloneLoaders
144+ unless (loader `elem` gitHubStandaloneLoaders) $ do
145+ throwError $ ReadThunkError_UnrecognizedLoader loader
135
146
136− txt <- LBS.readFile githubJson
147+ txt <- liftIO $ LBS.readFile githubJson
137 let p v = do
148 let p v = do
138 owner <- v Aeson..: "owner"
149 owner <- v Aeson..: "owner"
139 repo <- v Aeson..: "repo"
150 repo <- v Aeson..: "repo"
@@ -153,12 +164,14 @@ readThunk thunkDir = do
153 , _gitHubSource_private = fromMaybe False mPrivate
164 , _gitHubSource_private = fromMaybe False mPrivate
154 }
165 }
155 }
166 }
156− return $ parseMaybe p =<< decode txt
167+ case parseMaybe p =<< decode txt of
168+ Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
169+ Just ptr -> return ptr
157
170
158overwriteThunk :: FilePath -> ThunkPtr -> IO ()
171overwriteThunk :: FilePath -> ThunkPtr -> IO ()
159overwriteThunk target thunk = do
172overwriteThunk target thunk = do
160 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
173 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
161− Just _ <- readThunk target
174+ Right _ <- readThunk target
162
175
163 --TODO: Is there a safer way to do this overwriting?
176 --TODO: Is there a safer way to do this overwriting?
164 removeDirectoryRecursive target
177 removeDirectoryRecursive target
@@ -208,7 +221,7 @@ createThunkWithLatest target s = do
208
221
209updateThunkToLatest :: FilePath -> IO ()
222updateThunkToLatest :: FilePath -> IO ()
210updateThunkToLatest target = do
223updateThunkToLatest target = do
211− Just ptr <- readThunk target
224+ Right ptr <- readThunk target
212 let src = _thunkPtr_source ptr
225 let src = _thunkPtr_source ptr
213 rev <- getLatestRev src
226 rev <- getLatestRev src
214 overwriteThunk target $ ThunkPtr
227 overwriteThunk target $ ThunkPtr
@@ -285,15 +298,30 @@ nixBuildThunkAttrWithCache thunkDir attr = do
285 case cacheHit of
298 case cacheHit of
286 Just c -> return c
299 Just c -> return c
287 Nothing -> do
300 Nothing -> do
288− hPutStrLn stderr (mconcat [ thunkDir, ":", attr, " not cached, building ..."])
301+ hPutStrLn stderr (mconcat [thunkDir, ": ", attr, " not cached, building ..."])
289− (_, _, err, p) <- runInteractiveProcess "nix-build"
302+ _ <- nixBuild $ def
303+ { _nixBuildConfig_target = Target
290− [ thunkDir
304+ { _target_path = thunkDir
291− , "-A", attr
305+ , _target_attr = Just attr
292− , "--indirect", "--add-root", cachePath
306+ }
293− ] Nothing Nothing
307+ , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
294− waitForProcess p >>= \case
308+ }
295− ExitSuccess -> return ()
296− _ -> do
297− LBS.putStr =<< LBS.hGetContents err
298− fail "nix-build failed"
299 return cachePath
309 return cachePath
310+
311+-- | Build a nix attribute, and cache the result if possible
312+nixBuildAttrWithCache :: FilePath
313+ -- ^ Path to directory containing Thunk
314+ -> String
315+ -- ^ Attribute to build
316+ -> IO FilePath
317+ -- ^ Symlink to cached or built nix output
318+nixBuildAttrWithCache exprPath attr = do
319+ readThunk exprPath >>= \case
320+ Right _ -> nixBuildThunkAttrWithCache exprPath attr
321+ Left _ -> nixBuild $ def
322+ { _nixBuildConfig_target = Target
323+ { _target_path = exprPath
324+ , _target_attr = Just attr
325+ }
326+ , _nixBuildConfig_outLink = OutLink_None
327+ }
skeleton/.obelisk/implnew file+1
@@ -0,0 +1 @@
1+../..