git.iko.soy/obelisk
on 2cea7df help sign in
obelisk/lib/command/src/Obelisk/Command/Utils.hs
180 lines 6.5 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 qualified System.Process as P
26import Text.Megaparsec as MP
27import Text.Megaparsec.Char as MP
29import Obelisk.App (MonadObelisk)
30import Obelisk.CliApp
32getObeliskExe :: IO FilePath
33getObeliskExe = getExecutablePath >>= canonicalizePath
35-- Check whether the working directory is clean
36checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool
37checkGitCleanStatus repo withIgnored = do
38 let
39 runGit = readProcessAndLogStderr Debug . gitProc repo
40 gitStatus = runGit $ ["status", "--porcelain"] <> bool [] ["--ignored"] withIgnored
41 gitDiff = runGit ["diff"]
42 T.null <$> liftA2 (<>) gitStatus gitDiff
44-- | Ensure that git repo is clean
45ensureCleanGitRepo :: MonadObelisk m => FilePath -> Bool -> Text -> m ()
46ensureCleanGitRepo path withIgnored s =
47 withSpinnerNoTrail ("Ensuring clean git repo at " <> T.pack path) $ do
48 checkGitCleanStatus path withIgnored >>= \case
49 False -> do
50 statusDebug <- readGitProcess path $ ["status"] <> bool [] ["--ignored"] withIgnored
51 putLog Warning "Working copy is unsaved; git status:"
52 putLog Notice statusDebug
53 failWith s
54 True -> pure ()
56initGit :: MonadObelisk m => FilePath -> m ()
57initGit repo = do
58 let git = callProcessAndLogOutput (Debug, Debug) . gitProc repo
59 git ["init"]
60 git ["add", "."]
61 git ["commit", "-m", "Initial commit."]
63gitProcNoRepo :: [String] -> P.CreateProcess
64gitProcNoRepo = P.proc "git"
66gitProc :: FilePath -> [String] -> P.CreateProcess
67gitProc repo = gitProcNoRepo . runGitInDir
68 where
69 runGitInDir args' = case filter (not . null) args' of
70 args@("clone":_) -> args <> [repo]
71 args -> ["-C", repo] <> args
73-- | Recursively copy a directory using `cp -a`
74copyDir :: FilePath -> FilePath -> P.CreateProcess
75copyDir src dest =
76 (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }
78readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text
79readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo
81processToShellString :: FilePath -> [String] -> String
82processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)
83 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"
85-- | A simpler wrapper for CliApp's most used process function with sensible defaults.
86runProc :: MonadObelisk m => P.CreateProcess -> m ()
87runProc = callProcessAndLogOutput (Notice, Error)
89-- | Like runProc, but all output goes to Debug logging level
90runProcSilently :: MonadObelisk m => P.CreateProcess -> m ()
91runProcSilently = callProcessAndLogOutput (Debug, Debug)
93-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.
94readProc :: MonadObelisk m => P.CreateProcess -> m Text
95readProc = readProcessAndLogOutput (Debug, Error)
97tshow :: Show a => a -> Text
98tshow = T.pack . show
100gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
101gitLookupDefaultBranch (refs, _) = do
102 ref <- case M.lookup GitRef_Head refs of
103 Just ref -> pure ref
104 Nothing -> throwError
105 "No symref entry for HEAD. \
106 \ Is your git version at least 1.8.5? \
107 \ Otherwise `git ls-remote --symref` will not work."
108 case ref of
109 GitRef_Branch b -> pure b
110 _ -> throwError $
111 "Default ref " <> showGitRef ref <> " is not a branch!"
113gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
114gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
115 Just a -> pure a
116 Nothing -> throwError $ "Did not find commit for " <> showGitRef ref
118gitLsRemote
119 :: MonadObelisk m
120 => String
121 -> Maybe GitRef
122 -> m GitLsRemoteMaps
123gitLsRemote repository mRef = do
124 t <- readProc $ gitProcNoRepo $
125 ["ls-remote", "--symref", repository]
126 ++ (maybeToList $ T.unpack . showGitRef <$> mRef)
127 maps <- case MP.runParser parseLsRemote "" t of
128 Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err
129 Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table
130 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)
131 pure maps
133lexeme :: Parsec Void Text a -> Parsec Void Text a
134lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $
135 flip elem [' ', '\t']
137-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
138-- ref: refs/heads/master HEAD
139-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master
140parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]
141parseLsRemote =
142 many ((fmap Left (try parseRef) <|> fmap Right parseCommit) <* try MP.eol) <* MP.eof
143 where
144 parseRef :: Parsec Void Text (GitRef, GitRef)
145 parseRef = MP.label "ref and symbolic ref" $ do
146 _ <- lexeme "ref:"
147 ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
148 symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref") $ not . isSpace
149 return (toGitRef symbolicRef, toGitRef ref)
150 parseCommit :: Parsec Void Text (GitRef, CommitId)
151 parseCommit = MP.label "commit and ref" $ do
152 commitId <- lexeme $ MP.takeWhileP (Just "commit id") $ not . isSpace
153 ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace
154 return (toGitRef ref, commitId)
156data GitRef
157 = GitRef_Head
158 | GitRef_Branch Text
159 | GitRef_Tag Text
160 | GitRef_Other Text
161 deriving (Show, Eq, Ord)
163showGitRef :: GitRef -> Text
164showGitRef = \case
165 GitRef_Head -> "HEAD"
166 GitRef_Branch x -> "refs/heads/" <> x
167 GitRef_Tag x -> "refs/tags/" <> x
168 GitRef_Other x -> x
170toGitRef :: Text -> GitRef
171toGitRef = \case
172 "HEAD" -> GitRef_Head
173 r -> if
174 | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s
175 | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s
176 | otherwise -> GitRef_Other r
178type CommitId = Text
180type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)