git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/command/src/Obelisk/Command/Utils.hs
189 lines 7.0 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiWayIf #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PatternGuards #-}
7module Obelisk.Command.Utils where
9import Control.Applicative hiding (many)
10import Control.Monad.Except
11import Data.Bool (bool)
12import qualified Text.Megaparsec.Char.Lexer as ML
13import Data.Bifunctor
14import Data.Char
15import Data.Either
16import Data.Semigroup ((<>))
17import Data.Map (Map)
18import qualified Data.Map as M
19import Data.Maybe (maybeToList)
20import Data.Text (Text)
21import qualified Data.Text as T
22import Data.Void (Void)
23import System.Directory (canonicalizePath)
24import System.Environment (getExecutablePath)
25import System.Exit (ExitCode)
26import qualified System.Process as P
27import Text.Megaparsec as MP
28import Text.Megaparsec.Char as MP
30import Obelisk.App (MonadObelisk)
31import Obelisk.CliApp
33getObeliskExe :: IO FilePath
34getObeliskExe = getExecutablePath >>= canonicalizePath
36-- Check whether the working directory is clean
37checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool
38checkGitCleanStatus repo withIgnored = do
39 let
40 runGit = readProcessAndLogStderr Debug . gitProc repo
41 gitStatus = runGit $ ["status", "--porcelain"] <> bool [] ["--ignored"] withIgnored
42 gitDiff = runGit ["diff"]
43 T.null <$> liftA2 (<>) gitStatus gitDiff
45-- | Ensure that git repo is clean
46ensureCleanGitRepo :: MonadObelisk m => FilePath -> Bool -> Text -> m ()
47ensureCleanGitRepo path withIgnored s =
48 withSpinnerNoTrail ("Ensuring clean git repo at " <> T.pack path) $ do
49 checkGitCleanStatus path withIgnored >>= \case
50 False -> do
51 statusDebug <- readGitProcess path $ ["status"] <> bool [] ["--ignored"] withIgnored
52 putLog Warning "Working copy is unsaved; git status:"
53 putLog Notice statusDebug
54 failWith s
55 True -> pure ()
57initGit :: MonadObelisk m => FilePath -> m ()
58initGit repo = do
59 let git = callProcessAndLogOutput (Debug, Debug) . gitProc repo
60 git ["init"]
61 git ["add", "."]
62 git ["commit", "-m", "Initial commit."]
64gitProcNoRepo :: [String] -> P.CreateProcess
65gitProcNoRepo = P.proc "git"
67gitProc :: FilePath -> [String] -> P.CreateProcess
68gitProc repo = gitProcNoRepo . runGitInDir
69 where
70 runGitInDir args' = case filter (not . null) args' of
71 args@("clone":_) -> args <> [repo]
72 args -> ["-C", repo] <> args
74-- | Recursively copy a directory using `cp -a`
75copyDir :: FilePath -> FilePath -> P.CreateProcess
76copyDir src dest =
77 (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }
79readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text
80readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo
82readGitProcessNoRepo :: MonadObelisk m => [String] -> m Text
83readGitProcessNoRepo = readProcessAndLogOutput (Debug, Notice) . gitProcNoRepo
85processToShellString :: FilePath -> [String] -> String
86processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)
87 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"
89-- | A simpler wrapper for CliApp's most used process function with sensible defaults.
90runProc :: MonadObelisk m => P.CreateProcess -> m ()
91runProc = callProcessAndLogOutput (Notice, Error)
93-- | Like runProc, but all output goes to Debug logging level
94runProcSilently :: MonadObelisk m => P.CreateProcess -> m ()
95runProcSilently = callProcessAndLogOutput (Debug, Debug)
97-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.
98readProc :: MonadObelisk m => P.CreateProcess -> m Text
99readProc = readProcessAndLogOutput (Debug, Error)
101tshow :: Show a => a -> Text
102tshow = T.pack . show
104gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
105gitLookupDefaultBranch (refs, _) = do
106 ref <- case M.lookup GitRef_Head refs of
107 Just ref -> pure ref
108 Nothing -> throwError
109 "No symref entry for HEAD. \
110 \ Is your git version at least 1.8.5? \
111 \ Otherwise `git ls-remote --symref` will not work."
112 case ref of
113 GitRef_Branch b -> pure b
114 _ -> throwError $
115 "Default ref " <> showGitRef ref <> " is not a branch!"
117gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
118gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
119 Just a -> pure a
120 Nothing -> throwError $ "Did not find commit for " <> showGitRef ref
122gitLsRemote
123 :: MonadObelisk m
124 => String
125 -> Maybe GitRef
126 -> Maybe String
127 -> m (ExitCode, GitLsRemoteMaps)
128gitLsRemote repository mRef mBranch = do
129 (exitCode, out, _err) <- case mBranch of
130 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $
131 ["ls-remote", "--exit-code", "--symref", repository]
132 ++ (maybeToList $ T.unpack . showGitRef <$> mRef)
133 Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $
134 ["ls-remote", "--exit-code", repository, branchName]
135 let t = T.pack out
136 maps <- case MP.runParser parseLsRemote "" t of
137 Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err
138 Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table
139 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)
140 pure (exitCode, maps)
142lexeme :: Parsec Void Text a -> Parsec Void Text a
143lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $
144 flip elem [' ', '\t']
146-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
147-- ref: refs/heads/master HEAD
148-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master
149parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]
150parseLsRemote =
151 many ((fmap Left (try parseRef) <|> fmap Right parseCommit) <* try MP.eol) <* MP.eof
152 where
153 parseRef :: Parsec Void Text (GitRef, GitRef)
154 parseRef = MP.label "ref and symbolic ref" $ do
155 _ <- lexeme "ref:"
156 ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
157 symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref") $ not . isSpace
158 return (toGitRef symbolicRef, toGitRef ref)
159 parseCommit :: Parsec Void Text (GitRef, CommitId)
160 parseCommit = MP.label "commit and ref" $ do
161 commitId <- lexeme $ MP.takeWhileP (Just "commit id") $ not . isSpace
162 ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
163 return (toGitRef ref, commitId)
165data GitRef
166 = GitRef_Head
167 | GitRef_Branch Text
168 | GitRef_Tag Text
169 | GitRef_Other Text
170 deriving (Show, Eq, Ord)
172showGitRef :: GitRef -> Text
173showGitRef = \case
174 GitRef_Head -> "HEAD"
175 GitRef_Branch x -> "refs/heads/" <> x
176 GitRef_Tag x -> "refs/tags/" <> x
177 GitRef_Other x -> x
179toGitRef :: Text -> GitRef
180toGitRef = \case
181 "HEAD" -> GitRef_Head
182 r -> if
183 | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s
184 | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s
185 | otherwise -> GitRef_Other r
187type CommitId = Text
189type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)