diff --git a/app/App.hs b/app/App.hs index e63a739..99d0c09 100644 --- a/app/App.hs +++ b/app/App.hs @@ -28,6 +28,7 @@ type AppConfig = MonadReader Options data AppError = TagError TagSearchOutcome | InvalidConfigError [ParseConfigError] + | CacheError FingerprintOutcome newtype App a = App { runApp :: ReaderT Options (ExceptT AppError IO) a @@ -68,6 +69,7 @@ termsWithAlternatesFromConfig = do renderError :: AppError -> IO () renderError (TagError e) = V.missingTagsFileError e renderError (InvalidConfigError e) = V.invalidConfigError e +renderError (CacheError e) = V.fingerprintError e retrieveGitContext :: TermMatchSet -> App TermMatchSet retrieveGitContext tms = do @@ -97,10 +99,14 @@ calculateTagInput = do withCache :: IO SearchResults -> App SearchResults withCache f = - liftIO . operateCache =<< runWithCache + operateCache =<< runWithCache where - operateCache b = if b then withCache' f else f - withCache' = fmap SearchResults . cached "term-matches" . fmap fromResults + operateCache b = if b then withCache' f else liftIO f + withCache' :: IO SearchResults -> App SearchResults + withCache' r = + either (throwError . CacheError) (return . SearchResults) =<< + liftIO (cached "term-matches" $ fmap fromResults r) + optionFilters :: AppConfig m => TermMatchSet -> m TermMatchSet optionFilters tms = foldl (>>=) (pure tms) matchSetFilters diff --git a/src/Unused/CLI/Views.hs b/src/Unused/CLI/Views.hs index 256a5dc..b7a5545 100644 --- a/src/Unused/CLI/Views.hs +++ b/src/Unused/CLI/Views.hs @@ -7,4 +7,5 @@ import Unused.CLI.Views.AnalysisHeader as X import Unused.CLI.Views.GitSHAsHeader as X import Unused.CLI.Views.MissingTagsFileError as X import Unused.CLI.Views.InvalidConfigError as X +import Unused.CLI.Views.FingerprintError as X import Unused.CLI.Views.SearchResult as X diff --git a/src/Unused/CLI/Views/FingerprintError.hs b/src/Unused/CLI/Views/FingerprintError.hs new file mode 100644 index 0000000..c7edaf6 --- /dev/null +++ b/src/Unused/CLI/Views/FingerprintError.hs @@ -0,0 +1,19 @@ +module Unused.CLI.Views.FingerprintError + ( fingerprintError + ) where + +import Data.List (intercalate) +import Unused.Cache.DirectoryFingerprint +import Unused.CLI.Views.Error + +fingerprintError :: FingerprintOutcome -> IO () +fingerprintError e = do + errorHeader "There was a problem generating a cache fingerprint:" + + printOutcomeMessage e + +printOutcomeMessage :: FingerprintOutcome -> IO () +printOutcomeMessage (MD5ExecutableNotFound execs) = + putStrLn $ + "Unable to find any of the following executables \ + \in your PATH: " ++ intercalate ", " execs diff --git a/src/Unused/Cache.hs b/src/Unused/Cache.hs index 90de308..772f6da 100644 --- a/src/Unused/Cache.hs +++ b/src/Unused/Cache.hs @@ -1,5 +1,6 @@ module Unused.Cache - ( cached + ( FingerprintOutcome(..) + , cached ) where import Control.Monad.IO.Class (liftIO) @@ -8,16 +9,16 @@ import System.Directory import Data.Csv (FromRecord, ToRecord, HasHeader(..), encode, decode) import Data.Vector (toList) import qualified Data.ByteString.Lazy as BS -import Unused.Cache.DirectoryFingerprint (sha) +import Unused.Cache.DirectoryFingerprint newtype CacheFileName = CacheFileName String type Cache = ReaderT CacheFileName IO -cached :: (FromRecord a, ToRecord a) => String -> IO [a] -> IO [a] -cached context f = - runReaderT fromCache =<< cacheFileName context +cached :: (FromRecord a, ToRecord a) => String -> IO [a] -> IO (Either FingerprintOutcome [a]) +cached cachePrefix f = + mapM fromCache =<< cacheFileName cachePrefix where - fromCache = maybe (writeCache =<< liftIO f) return =<< readCache + fromCache = runReaderT $ maybe (writeCache =<< liftIO f) return =<< readCache writeCache :: ToRecord a => [a] -> Cache [a] writeCache [] = return [] @@ -38,11 +39,12 @@ readCache = do where processCsv = either (const Nothing) (Just . toList) -cacheFileName :: String -> IO CacheFileName +cacheFileName :: String -> IO (Either FingerprintOutcome CacheFileName) cacheFileName context = do putStrLn "\n\nCalculating cache fingerprint... " - currentSha <- sha - return $ CacheFileName $ cacheDirectory ++ "/" ++ context ++ "-" ++ currentSha ++ ".csv" + fmap toFileName <$> sha + where + toFileName s = CacheFileName $ cacheDirectory ++ "/" ++ context ++ "-" ++ s ++ ".csv" cacheDirectory :: String cacheDirectory = "tmp/unused" diff --git a/src/Unused/Cache/DirectoryFingerprint.hs b/src/Unused/Cache/DirectoryFingerprint.hs index 62aa6ba..908c065 100644 --- a/src/Unused/Cache/DirectoryFingerprint.hs +++ b/src/Unused/Cache/DirectoryFingerprint.hs @@ -1,31 +1,53 @@ module Unused.Cache.DirectoryFingerprint - ( sha + ( FingerprintOutcome(..) + , sha ) where import System.Process +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader +import qualified System.Directory as D +import qualified Data.Char as C import Data.Maybe (fromMaybe) import Unused.Cache.FindArgsFromIgnoredPaths -import Unused.Util (readIfFileExists) +import Unused.Util (safeHead, readIfFileExists) -sha :: IO String -sha = - getSha <$> (fileList >>= sortInput >>= md5Result) +type MD5Config = ReaderT String IO + +data FingerprintOutcome + = MD5ExecutableNotFound [String] + +sha :: IO (Either FingerprintOutcome String) +sha = do + md5Executable' <- md5Executable + case md5Executable' of + Just exec -> + Right . getSha <$> runReaderT (fileList >>= sortInput >>= md5Result) exec + Nothing -> return $ Left $ MD5ExecutableNotFound supportedMD5Executables where - getSha = head' . lines - head' (x:_) = x - head' _ = "" + getSha = takeWhile C.isAlphaNum . fromMaybe "" . safeHead . lines -fileList :: IO String +fileList :: MD5Config String fileList = do - filterNamePathArgs <- findArgs <$> ignoredPaths - let args = [".", "-type", "f", "-not", "-path", "*/.git/*"] ++ filterNamePathArgs ++ ["-exec", "md5", "{}", "+"] - readProcess "find" args "" + filterNamePathArgs <- liftIO $ findArgs <$> ignoredPaths + md5exec <- ask + let args = [".", "-type", "f", "-not", "-path", "*/.git/*"] ++ filterNamePathArgs ++ ["-exec", md5exec, "{}", "+"] + liftIO $ readProcess "find" args "" -sortInput :: String -> IO String -sortInput = readProcess "sort" ["-k", "2"] +sortInput :: String -> MD5Config String +sortInput = liftIO . readProcess "sort" ["-k", "2"] -md5Result :: String -> IO String -md5Result = readProcess "md5" [] +md5Result :: String -> MD5Config String +md5Result r = do + md5exec <- ask + liftIO $ readProcess md5exec [] r ignoredPaths :: IO [String] ignoredPaths = fromMaybe [] <$> (fmap lines <$> readIfFileExists ".gitignore") + +md5Executable :: IO (Maybe String) +md5Executable = + safeHead . concat <$> mapM D.findExecutables supportedMD5Executables + +supportedMD5Executables :: [String] +supportedMD5Executables = ["md5", "md5sum"] diff --git a/src/Unused/Util.hs b/src/Unused/Util.hs index efb48ff..4be70ce 100644 --- a/src/Unused/Util.hs +++ b/src/Unused/Util.hs @@ -1,6 +1,7 @@ module Unused.Util ( groupBy , stringToInt + , safeHead , readIfFileExists ) where @@ -15,6 +16,10 @@ groupBy f = map (f . head &&& id) . L.groupBy ((==) `on` f) . L.sortBy (compare `on` f) +safeHead :: [a] -> Maybe a +safeHead (x:_) = Just x +safeHead _ = Nothing + stringToInt :: String -> Maybe Int stringToInt xs | all isDigit xs = Just $ loop 0 xs diff --git a/unused.cabal b/unused.cabal index 8763d97..9c7cdac 100644 --- a/unused.cabal +++ b/unused.cabal @@ -48,6 +48,7 @@ library , Unused.CLI.Views.GitSHAsHeader , Unused.CLI.Views.MissingTagsFileError , Unused.CLI.Views.InvalidConfigError + , Unused.CLI.Views.FingerprintError , Unused.CLI.Views.SearchResult , Unused.CLI.Views.SearchResult.ColumnFormatter , Unused.CLI.Views.SearchResult.Internal