@@ -8,12 +8,15 @@
88{-# LANGUAGE ScopedTypeVariables #-}
99{-# LANGUAGE TypeApplications #-}
1010module Obelisk.Command.Thunk
11− ( ThunkPtr (..)
11+ ( GitHubSource (..)
12+ , ReadThunkError (..)
13+ , ThunkConfig (..)
14+ , ThunkData (..)
15+ , ThunkPackConfig (..)
16+ , ThunkPtr (..)
1217 , ThunkRev (..)
1318 , ThunkSource (..)
14− , ThunkData (..)
15− , ReadThunkError (..)
16− , GitHubSource (..)
19+ , ThunkUpdateConfig (..)
1720 , getThunkGitBranch
1821 , getLatestRev
1922 , updateThunkToLatest
@@ -111,6 +114,7 @@ data GitHubSource = GitHubSource
111114 { _gitHubSource_owner :: Name Owner
112115 , _gitHubSource_repo :: Name Repo
113116 , _gitHubSource_branch :: Maybe (Name Branch)
117+ , _gitHubSource_private :: Bool
114118 }
115119 deriving (Show, Eq, Ord)
116120
@@ -118,9 +122,24 @@ data GitSource = GitSource
118122 { _gitSource_url :: URI
119123 , _gitSource_branch :: Maybe (Name Branch)
120124 , _gitSource_fetchSubmodules :: Bool
125+ , _gitSource_private :: Bool
121126 }
122127 deriving (Show, Eq, Ord)
123128
129+newtype ThunkConfig = ThunkConfig
130+ { _thunkConfig_private :: Maybe Bool
131+ } deriving Show
132+
133+data ThunkUpdateConfig = ThunkUpdateConfig
134+ { _thunkUpdateConfig_branch :: Maybe String
135+ , _thunkUpdateConfig_config :: ThunkConfig
136+ } deriving Show
137+
138+data ThunkPackConfig = ThunkPackConfig
139+ { _thunkPackConfig_force :: Bool
140+ , _thunkPackConfig_config :: ThunkConfig
141+ } deriving Show
142+
124143-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
125144forgetGithub :: Bool -> GitHubSource -> GitSource
126145forgetGithub useSsh s = GitSource
@@ -142,6 +161,7 @@ forgetGithub useSsh s = GitSource
142161 }
143162 , _gitSource_branch = _gitHubSource_branch s
144163 , _gitSource_fetchSubmodules = False
164+ , _gitSource_private = _gitHubSource_private s
145165 }
146166
147167getThunkGitBranch :: ThunkPtr -> Maybe Text
@@ -286,10 +306,12 @@ parseGitHubSource v = do
286306 owner <- v Aeson..: "owner"
287307 repo <- v Aeson..: "repo"
288308 branch <- v Aeson..:! "branch"
309+ private <- v Aeson..:? "private"
289310 pure $ GitHubSource
290311 { _gitHubSource_owner = owner
291312 , _gitHubSource_repo = repo
292313 , _gitHubSource_branch = branch
314+ , _gitHubSource_private = fromMaybe False private
293315 }
294316
295317parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -297,10 +319,12 @@ parseGitSource v = do
297319 Just url <- parseGitUri <$> v Aeson..: "url"
298320 branch <- v Aeson..:! "branch"
299321 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
322+ private <- v Aeson..:? "private"
300323 pure $ GitSource
301324 { _gitSource_url = url
302325 , _gitSource_branch = branch
303326 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
327+ , _gitSource_private = fromMaybe False private
304328 }
305329
306330overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
@@ -327,6 +351,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
327351 , ("branch" .=) <$> _gitHubSource_branch s
328352 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
329353 , Just $ "sha256" .= _thunkRev_nixSha256 rev
354+ , Just $ "private" .= _gitHubSource_private s
330355 ]
331356 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
332357 [ Just $ "url" .= render (_gitSource_url s)
@@ -334,6 +359,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
334359 , ("branch" .=) <$> _gitSource_branch s
335360 , Just $ "sha256" .= _thunkRev_nixSha256 rev
336361 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
362+ , Just $ "private" .= _gitSource_private s
337363 ]
338364 where
339365 githubCfg = defConfig
@@ -354,6 +380,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
354380 [ "url"
355381 , "rev"
356382 , "sha256"
383+ , "private"
357384 , "fetchSubmodules"
358385 ] <> compare
359386 , confTrailingNewline = True
@@ -377,8 +404,8 @@ createThunkWithLatest target s = do
377404 , _thunkPtr_rev = rev
378405 }
379406
380−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()
381−updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
407+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
408+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
382409 checkThunkDirectory "ob thunk update directory cannot be '.'" target
383410 -- check to see if thunk should be updated to a specific branch or just update it's current branch
384411 case mBranch of
@@ -390,7 +417,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
390417 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
391418 let src = _thunkPtr_source ptr
392419 rev <- getLatestRev src
393− overwriteThunk overwrite $ ThunkPtr
420+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
394421 { _thunkPtr_source = src
395422 , _thunkPtr_rev = rev
396423 }
@@ -398,17 +425,17 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
398425 Left err -> failWith $ T.pack $ "thunk update: " <> show err
399426 Right c -> case c of
400427 ThunkData_Packed t -> case _thunkPtr_source t of
401− ThunkSource_Git tsg -> setThunk target tsg branch
428+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
402429 ThunkSource_GitHub tsgh -> do
403430 let tsg = forgetGithub False tsgh
404− setThunk target tsg branch
431+ setThunk thunkConfig target tsg branch
405432 ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."
406433
407−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()
408−setThunk target gs branch = do
434+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
435+setThunk thunkConfig target gs branch = do
409436 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
410437 overwriteThunk target newThunkPtr
411− updateThunkToLatest target Nothing
438+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
412439
413440-- | All recognized github standalone loaders, ordered from newest to oldest.
414441-- This tool will only ever produce the newest one when it writes a thunk.
@@ -459,26 +486,20 @@ gitHubStandaloneLoaderV3 = T.unlines
459486gitHubStandaloneLoaderV4 :: Text
460487gitHubStandaloneLoaderV4 = T.unlines
461488 [ "# DO NOT HAND-EDIT THIS FILE"
462− , "let"
463− , " fetch = { private ? false, ... }@args:"
464− , " if private && builtins.hasAttr \"fetchGit\" builtins"
465− , " then fetchFromGitHubPrivate args"
466− , " else fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
467− , " fetchFromGitHub = if builtins.hasAttr \"fetchTarball\" builtins then"
468− , " ({ owner, repo, rev, sha256, ... }: builtins.fetchTarball {"
469− , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\";"
470− , " inherit sha256; })"
471− , " else (import <nixpkgs> {}).fetchFromGitHub;"
472− , " fetchFromGitHubPrivate = { owner, repo, rev, sha256, ... }:"
473− , " (import <nixpkgs> {}).fetchFromGitHub"
474− , " { inherit owner repo rev sha256; private = true; }"
489+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
490+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"
491+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
492+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"
493+ , " inherit owner repo rev sha256 fetchSubmodules private;"
494+ , " };"
475495 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
476496 ]
477497
478498plainGitStandaloneLoaders :: NonEmpty Text
479499plainGitStandaloneLoaders =
480− plainGitStandaloneLoaderV1 :|
481− [ plainGitStandaloneLoaderV2
500+ plainGitStandaloneLoaderV3 :|
501+ [ plainGitStandaloneLoaderV1
502+ , plainGitStandaloneLoaderV2
482503 ]
483504
484505plainGitStandaloneLoaderV1 :: Text
@@ -499,6 +520,22 @@ plainGitStandaloneLoaderV2 = T.unlines
499520 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
500521 ]
501522
523+plainGitStandaloneLoaderV3 :: Text
524+plainGitStandaloneLoaderV3 = T.unlines
525+ [ "# DO NOT HAND-EDIT THIS FILE"
526+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
527+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
528+ , " if firstChar == \"/\" then /. + url"
529+ , " else if firstChar == \".\" then ./. + url"
530+ , " else url;"
531+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
532+ , " url = realUrl; inherit rev;"
533+ , " } else (import <nixpkgs> {}).fetchgit {"
534+ , " url = realUrl; inherit rev sha256;"
535+ , " };"
536+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
537+ ]
538+
502539thunkFileNames :: [FilePath]
503540thunkFileNames = ["default.nix", "github.json", "git.json"]
504541
@@ -592,7 +629,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
592629 return tmpThunk
593630 Right _ -> failWith "Thunk is not packed"
594631 updateThunkFromTmp p' = do
595− _ <- packThunk' True False p'
632+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
596633 callProcessAndLogOutput (Notice, Error) $
597634 proc "cp" ["-r", "-T", p', p]
598635
@@ -642,21 +679,29 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
642679 proc "mv" ["-T", tmpRepo, thunkDir]
643680
644681--TODO: add a rollback mode to pack to the original thunk
645−packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
682+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
646683packThunk = packThunk' False
647684
648−packThunk' :: MonadObelisk m => Bool -> Bool -> FilePath -> m ThunkPtr
649−packThunk' noTrail force thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
685+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
686+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
650687 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
651688 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
652689 Right (ThunkData_Checkout _) -> do
653690 withSpinner' ("Packing thunk " <> T.pack thunkDir)
654691 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
655− thunkPtr <- getThunkPtr (not force) thunkDir
692+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir
656693 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
657694 liftIO $ createThunk thunkDir thunkPtr
658695 pure thunkPtr
659696
697+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
698+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
699+ Nothing -> ptr
700+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
701+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
702+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
703+ }
704+
660705getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
661706getThunkPtr checkClean thunkDir = do
662707 when checkClean $ ensureCleanGitRepo thunkDir True
@@ -840,12 +885,14 @@ uriToThunkSource u
840885 repoish' = unRText repoish
841886 in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
842887 , _gitHubSource_branch = N <$> mbranch
888+ , _gitHubSource_private = False -- TODO: Can we try something to infer this?
843889 }
844890
845891 | otherwise = \mbranch -> ThunkSource_Git $ GitSource
846892 { _gitSource_url = u
847893 , _gitSource_branch = N <$> mbranch
848894 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
895+ , _gitSource_private = False -- TODO: Can we try something to infer this?
849896 }
850897
851898-- Funny signature indicates no effects depend on the optional branch name.