git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/command/src/Obelisk/Command/Upgrade/Hash.hs
114 lines 4.7 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TupleSections #-}
6-- | Hash a git repo or arbitrary directory using nix-hash.
7module Obelisk.Command.Upgrade.Hash
8 ( getDirectoryHash
9 , getHashAtGitRevision
10 ) where
12import Control.Monad (forM, forM_)
13import Control.Monad.IO.Class (liftIO)
14import Data.Bool (bool)
15import Data.Maybe (catMaybes)
16import Data.Semigroup ((<>))
17import Data.Text (Text)
18import qualified Data.Text as T
19import System.Directory
20import System.FilePath
21import System.IO.Temp
22import System.Process (cwd, proc)
24import Obelisk.App (MonadObelisk)
25import Obelisk.CliApp
26import Obelisk.Command.Utils
28import Obelisk.Migration
30-- | Get the unique hash of the given directory
31--
32-- Excludes the following before computing the hash:
33-- * the specified top-level files/ directories.
34-- * .git directory
35-- * untracked Git files
36-- * ignored Git files
37-- * empty directories
38--
39-- Uses the same predictive algorithm as that of Nix (`nix-hash`).
40--
41-- This function will do a full copy of the directory to a temporary location before
42-- computing the hash. Because it will be deleting the files in exclude list, and
43-- other files if the directory is a git repo, which needs to be done as `nix-hash`
44-- doesn't support taking an excludes list.
45getDirectoryHash :: MonadObelisk m => [FilePath] -> FilePath -> m Hash
46getDirectoryHash excludes dir = withSystemTempDirectory "obelisk-hash-" $ \tmpDir -> do
47 withSpinnerNoTrail (T.pack $ "Copying " <> dir <> " to " <> tmpDir) $ do
48 runProc $ copyDir dir tmpDir
49 getDirectoryHashDestructive excludes tmpDir
51getDirectoryHashDestructive :: MonadObelisk m => [FilePath] -> FilePath -> m Hash
52getDirectoryHashDestructive excludes dir = do
53 liftIO (doesDirectoryExist $ dir </> ".git") >>= \case
54 True -> do
55 tidyUpGitWorkingCopy dir
56 withSpinnerNoTrail "Removing .git directory" $
57 liftIO $ removePathForcibly $ dir </> ".git"
58 False -> pure ()
59 withSpinnerNoTrail "Removing excluded paths" $ do
60 forM_ (fmap (dir </>) excludes) $
61 liftIO . removePathForcibly
62 nixHash dir
64getHashAtGitRevision :: MonadObelisk m => [Text] -> [FilePath] -> FilePath -> m [Hash]
65getHashAtGitRevision revs excludes dir = withSystemTempDirectory "obelisk-hashrev-" $ \tmpDir -> do
66 withSpinnerNoTrail (T.pack $ "Copying " <> dir <> " to " <> tmpDir) $ do
67 runProc $ copyDir dir tmpDir
68 tidyUpGitWorkingCopy tmpDir
69 -- Discard changes to tracked files
70 runProcSilently $ gitProc tmpDir ["reset", "--hard"]
71 forM revs $ \rev -> do
72 runProcSilently $ gitProc tmpDir ["checkout", T.unpack rev]
73 -- Checking out an arbitrary revision can leave untracked files (from
74 -- previous revison) around, so tidy them up.
75 tidyUpGitWorkingCopy tmpDir
76 withFilesStashed tmpDir (excludes <> [".git"]) $
77 nixHash tmpDir
78 where
79 withFilesStashed base fs m = withSystemTempDirectory "obelisk-hashrev-stash-" $ \stashDir -> do
80 existingPaths <- fmap catMaybes $ forM fs $ \p -> do
81 liftIO (doesPathExist $ base </> p) >>= pure . bool Nothing (Just p)
82 forM_ existingPaths $ \p ->
83 liftIO $ renamePath (base </> p) (stashDir </> p)
84 result <- m
85 forM_ existingPaths $ \p ->
86 liftIO $ renamePath (stashDir </> p) (base </> p)
87 return result
89nixHash :: MonadObelisk m => FilePath -> m Hash
90nixHash dir = withSpinnerNoTrail "Running `nix-hash`" $
91 readProc $ proc "nix-hash" [dir]
93-- | Clean up the following files in the git working copy
94--
95-- * Paths ignored by .gitignore, and still present
96-- * Untracked files (not added to git index)
97-- * Any empty directories (these are not tracked by git)
98--
99-- Note that this leaves modified (staged or unstaged) files as they are.
100tidyUpGitWorkingCopy :: MonadObelisk m => FilePath -> m ()
101tidyUpGitWorkingCopy dir = withSpinnerNoTrail "Tidying up git working copy" $ do
102 ignored <- gitLsFiles dir ["--ignored", "--exclude-standard", "--others"]
103 untracked <- gitLsFiles dir ["--exclude-standard", "--others"]
104 putLog Debug $ "Ignored: " <> T.pack (show $ length ignored) <> " files."
105 putLog Debug $ "Untracked files:\n" <> T.unlines untracked
106 withSpinnerNoTrail "Removing untracked and ignored files" $ do
107 forM_ (fmap ((dir </>) . T.unpack) $ ignored <> untracked) $
108 liftIO . removePathForcibly
109 -- Empty directories won't be included in these lists. Git doesn't track them
110 -- So we must delete these separately.
111 runProc $ proc "find" [dir, "-depth", "-empty", "-type", "d", "-delete"]
112 where
113 gitLsFiles pwd opts = fmap T.lines $ readProc $
114 (proc "git" $ ["ls-files", "."] <> opts) { cwd = Just pwd }