git.iko.soy/obelisk
on ae@static-which-prefetch help sign in
obelisk/lib/command/src/Obelisk/Command/Utils.hs
235 lines 8.3 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiWayIf #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE TemplateHaskell #-}
8module Obelisk.Command.Utils where
10import Control.Applicative hiding (many)
11import Control.Monad.Except
12import Data.Bool (bool)
13import Data.Bifunctor
14import Data.Char
15import Data.Either
16import Data.List (isInfixOf)
17import Data.Map (Map)
18import qualified Data.Map as M
19import Data.Maybe (maybeToList)
20import Data.Semigroup ((<>))
21import Data.Text (Text)
22import qualified Data.Text as T
23import Data.Void (Void)
24import System.Exit (ExitCode)
25import System.Which (staticWhich)
26import qualified Text.Megaparsec.Char.Lexer as ML
27import Text.Megaparsec as MP
28import Text.Megaparsec.Char as MP
30import Obelisk.App (MonadObelisk)
31import Obelisk.CliApp
33cp :: FilePath
34cp = $(staticWhich "cp")
36mvPath :: FilePath
37mvPath = $(staticWhich "mv")
39rmPath :: FilePath
40rmPath = $(staticWhich "rm")
42ghcidExePath :: FilePath
43ghcidExePath = $(staticWhich "ghcid")
45findExePath :: FilePath
46findExePath = $(staticWhich "find")
48nixExePath :: FilePath
49nixExePath = $(staticWhich "nix")
51nixBuildExePath :: FilePath
52nixBuildExePath = $(staticWhich "nix-build")
54jreKeyToolPath :: FilePath
55jreKeyToolPath = $(staticWhich "keytool")
57nixPrefetchGitPath :: FilePath
58nixPrefetchGitPath = $(staticWhich "nix-prefetch-git")
60nixPrefetchUrlPath :: FilePath
61nixPrefetchUrlPath = $(staticWhich "nix-prefetch-url")
63-- | Nix syntax requires relative paths to be prefixed by @./@ or
64-- @../@. This will make a 'FilePath' that can be embedded in a Nix
65-- expression.
66toNixPath :: FilePath -> FilePath
67toNixPath root | "/" `isInfixOf` root = root
68 | otherwise = "./" <> root
71-- Check whether the working directory is clean
72checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool
73checkGitCleanStatus repo withIgnored = do
74 let
75 runGit = readProcessAndLogStderr Debug . gitProc repo
76 gitStatus = runGit $ ["status", "--porcelain"] <> bool [] ["--ignored"] withIgnored
77 gitDiff = runGit ["diff"]
78 T.null <$> liftA2 (<>) gitStatus gitDiff
80-- | Ensure that git repo is clean
81ensureCleanGitRepo :: MonadObelisk m => FilePath -> Bool -> Text -> m ()
82ensureCleanGitRepo path withIgnored s =
83 withSpinnerNoTrail ("Ensuring clean git repo at " <> T.pack path) $ do
84 checkGitCleanStatus path withIgnored >>= \case
85 False -> do
86 statusDebug <- readGitProcess path $ ["status"] <> bool [] ["--ignored"] withIgnored
87 putLog Warning "Working copy is unsaved; git status:"
88 putLog Notice statusDebug
89 failWith s
90 True -> pure ()
92initGit :: MonadObelisk m => FilePath -> m ()
93initGit repo = do
94 let git = callProcessAndLogOutput (Debug, Debug) . gitProc repo
95 git ["init"]
96 git ["add", "."]
97 git ["commit", "-m", "Initial commit."]
99gitProcNoRepo :: [String] -> ProcessSpec
100gitProcNoRepo args = setEnvOverride (M.singleton "GIT_TERMINAL_PROMPT" "0" <>) $ proc "git" args
102gitProc :: FilePath -> [String] -> ProcessSpec
103gitProc repo = gitProcNoRepo . runGitInDir
104 where
105 runGitInDir args' = case filter (not . null) args' of
106 args@("clone":_) -> args <> [repo]
107 args -> ["-C", repo] <> args
109isolateGitProc :: ProcessSpec -> ProcessSpec
110isolateGitProc = setEnvOverride (overrides <>)
111 where
112 overrides = M.fromList
113 [ ("HOME", "/dev/null")
114 , ("GIT_CONFIG_NOSYSTEM", "1")
115 , ("GIT_TERMINAL_PROMPT", "0") -- git 2.3+
116 , ("GIT_ASKPASS", "echo") -- pre git 2.3 to just use empty password
117 , ("GIT_SSH_COMMAND", "ssh -o PreferredAuthentications password -o PubkeyAuthentication no -o GSSAPIAuthentication no")
118 ]
120-- | Recursively copy a directory using `cp -a` -- TODO: Should use -rT instead of -a
121copyDir :: FilePath -> FilePath -> ProcessSpec
122copyDir src dest =
123 setCwd (Just src) $ proc cp ["-a", ".", dest] -- TODO: This will break if dest is relative since we change cwd
125readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text
126readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo
128readGitProcessNoRepo :: MonadObelisk m => [String] -> m Text
129readGitProcessNoRepo = readProcessAndLogOutput (Debug, Notice) . gitProcNoRepo
131processToShellString :: FilePath -> [String] -> String
132processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)
133 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"
135-- | A simpler wrapper for CliApp's most used process function with sensible defaults.
136runProc :: MonadObelisk m => ProcessSpec -> m ()
137runProc = callProcessAndLogOutput (Notice, Error)
139-- | Like runProc, but all output goes to Debug logging level
140runProcSilently :: MonadObelisk m => ProcessSpec -> m ()
141runProcSilently = callProcessAndLogOutput (Debug, Debug)
143-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.
144readProc :: MonadObelisk m => ProcessSpec -> m Text
145readProc = readProcessAndLogOutput (Debug, Error)
147tshow :: Show a => a -> Text
148tshow = T.pack . show
150gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
151gitLookupDefaultBranch (refs, _) = do
152 ref <- case M.lookup GitRef_Head refs of
153 Just ref -> pure ref
154 Nothing -> throwError
155 "No symref entry for HEAD. \
156 \ Is your git version at least 1.8.5? \
157 \ Otherwise `git ls-remote --symref` will not work."
158 case ref of
159 GitRef_Branch b -> pure b
160 _ -> throwError $
161 "Default ref " <> showGitRef ref <> " is not a branch!"
163gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
164gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
165 Just a -> pure a
166 Nothing -> throwError $ "Did not find commit for " <> showGitRef ref
168gitLsRemote
169 :: MonadObelisk m
170 => String
171 -> Maybe GitRef
172 -> Maybe String
173 -> m (ExitCode, GitLsRemoteMaps)
174gitLsRemote repository mRef mBranch = do
175 (exitCode, out, _err) <- case mBranch of
176 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $
177 ["ls-remote", "--exit-code", "--symref", repository]
178 ++ maybeToList (T.unpack . showGitRef <$> mRef)
179 Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo
180 ["ls-remote", "--exit-code", repository, branchName]
181 let t = T.pack out
182 maps <- case MP.runParser parseLsRemote "" t of
183 Left err -> failWith $ T.pack $ MP.errorBundlePretty err
184 Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers table
185 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)
186 pure (exitCode, maps)
188lexeme :: Parsec Void Text a -> Parsec Void Text a
189lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $
190 flip elem [' ', '\t']
192-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
193-- ref: refs/heads/master HEAD
194-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master
195parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]
196parseLsRemote =
197 many ((fmap Left (try parseRef) <|> fmap Right parseCommit) <* try MP.eol) <* MP.eof
198 where
199 parseRef :: Parsec Void Text (GitRef, GitRef)
200 parseRef = MP.label "ref and symbolic ref" $ do
201 _ <- lexeme "ref:"
202 ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
203 symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref") $ not . isSpace
204 return (toGitRef symbolicRef, toGitRef ref)
205 parseCommit :: Parsec Void Text (GitRef, CommitId)
206 parseCommit = MP.label "commit and ref" $ do
207 commitId <- lexeme $ MP.takeWhileP (Just "commit id") $ not . isSpace
208 ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
209 return (toGitRef ref, commitId)
211data GitRef
212 = GitRef_Head
213 | GitRef_Branch Text
214 | GitRef_Tag Text
215 | GitRef_Other Text
216 deriving (Show, Eq, Ord)
218showGitRef :: GitRef -> Text
219showGitRef = \case
220 GitRef_Head -> "HEAD"
221 GitRef_Branch x -> "refs/heads/" <> x
222 GitRef_Tag x -> "refs/tags/" <> x
223 GitRef_Other x -> x
225toGitRef :: Text -> GitRef
226toGitRef = \case
227 "HEAD" -> GitRef_Head
228 r -> if
229 | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s
230 | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s
231 | otherwise -> GitRef_Other r
233type CommitId = Text
235type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)