diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,6 @@ import App.Commands import Control.Monad -import Data.Semigroup ((<>)) import Options.Applicative main :: IO () diff --git a/cabal-cache.cabal b/cabal-cache.cabal --- a/cabal-cache.cabal +++ b/cabal-cache.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-cache -version: 1.0.1.8 +version: 1.0.1.9 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache @@ -34,7 +34,7 @@ common directory { build-depends: directory >= 1.3.3.0 && < 1.4 } common exceptions { build-depends: exceptions >= 0.10.1 && < 0.11 } common filepath { build-depends: filepath >= 1.3 && < 1.5 } -common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 1.3 } +common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 2.1 } common hedgehog { build-depends: hedgehog >= 1.0 && < 1.1 } common hspec { build-depends: hspec >= 2.4 && < 3 } common http-client { build-depends: http-client >= 0.5.14 && < 0.7 } @@ -43,7 +43,7 @@ common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 } common lens { build-depends: lens >= 4.17 && < 5 } common mtl { build-depends: mtl >= 2.2.2 && < 2.3 } -common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.16 } +common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.17 } common process { build-depends: process >= 1.6.5.0 && < 1.7 } common raw-strings-qq { build-depends: raw-strings-qq >= 1.1 && < 2 } common relation { build-depends: relation >= 0.5 && < 0.6 } @@ -110,6 +110,9 @@ App.Commands.SyncToArchive App.Commands.Version App.Static + App.Static.Base + App.Static.Posix + App.Static.Windows HaskellWorks.CabalCache.AppError HaskellWorks.CabalCache.AWS.Env HaskellWorks.CabalCache.Concurrent.DownloadQueue diff --git a/src/App/Commands.hs b/src/App/Commands.hs --- a/src/App/Commands.hs +++ b/src/App/Commands.hs @@ -3,7 +3,6 @@ import App.Commands.SyncFromArchive import App.Commands.SyncToArchive import App.Commands.Version -import Data.Semigroup ((<>)) import Options.Applicative commands :: Parser (IO ()) diff --git a/src/App/Commands/SyncFromArchive.hs b/src/App/Commands/SyncFromArchive.hs --- a/src/App/Commands/SyncFromArchive.hs +++ b/src/App/Commands/SyncFromArchive.hs @@ -13,7 +13,7 @@ import Antiope.Options.Applicative import App.Commands.Options.Parser (text) import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions)) -import App.Static (homeDirectory) +import App.Static (cabalDirectory) import Control.Applicative import Control.Lens hiding ((<.>)) import Control.Monad (unless, void, when) @@ -23,7 +23,6 @@ import Data.ByteString.Lazy.Search (replace) import Data.Generics.Product.Any (the) import Data.Maybe -import Data.Semigroup ((<>)) import Foreign.C.Error (eXDEV) import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.IO.Error (catchErrno, exceptWarn, maybeToExcept) @@ -58,8 +57,8 @@ import qualified System.IO.Temp as IO import qualified System.IO.Unsafe as IO -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} skippable :: Z.Package -> Bool skippable package = (package ^. the @"packageType" == "pre-existing") @@ -218,7 +217,7 @@ ( long "store-path" <> help "Path to cabal store" <> metavar "DIRECTORY" - <> value (homeDirectory ".cabal" "store") + <> value (cabalDirectory "store") ) <*> optional ( strOption diff --git a/src/App/Commands/SyncToArchive.hs b/src/App/Commands/SyncToArchive.hs --- a/src/App/Commands/SyncToArchive.hs +++ b/src/App/Commands/SyncToArchive.hs @@ -14,7 +14,7 @@ import Antiope.Options.Applicative import App.Commands.Options.Parser (text) import App.Commands.Options.Types (SyncToArchiveOptions (SyncToArchiveOptions)) -import App.Static (homeDirectory) +import App.Static (cabalDirectory) import Control.Applicative import Control.Lens hiding ((<.>)) import Control.Monad (filterM, unless, when) @@ -23,7 +23,6 @@ import Data.Generics.Product.Any (the) import Data.List ((\\)) import Data.Maybe -import Data.Semigroup ((<>)) import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), ()) import HaskellWorks.CabalCache.Metadata (createMetadata) @@ -55,8 +54,8 @@ import qualified System.IO.Unsafe as IO import qualified UnliftIO.Async as IO -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} runSyncToArchive :: Z.SyncToArchiveOptions -> IO () runSyncToArchive opts = do @@ -173,13 +172,13 @@ ( long "archive-uri" <> help "Archive URI to sync to" <> metavar "S3_URI" - <> value (Local $ homeDirectory ".cabal" "archive") + <> value (Local $ cabalDirectory "archive") ) <*> strOption ( long "store-path" <> help "Path to cabal store" <> metavar "DIRECTORY" - <> value (homeDirectory ".cabal" "store") + <> value (cabalDirectory "store") ) <*> optional ( strOption diff --git a/src/App/Commands/Version.hs b/src/App/Commands/Version.hs --- a/src/App/Commands/Version.hs +++ b/src/App/Commands/Version.hs @@ -9,7 +9,6 @@ import App.Commands.Options.Parser (optsVersion) import Data.List -import Data.Semigroup ((<>)) import Options.Applicative hiding (columns) import qualified App.Commands.Options.Types as Z @@ -18,8 +17,8 @@ import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified Paths_cabal_cache as P -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} runVersion :: Z.VersionOptions -> IO () runVersion _ = do diff --git a/src/App/Static.hs b/src/App/Static.hs --- a/src/App/Static.hs +++ b/src/App/Static.hs @@ -1,8 +1,8 @@ module App.Static where -import qualified System.Directory as IO -import qualified System.IO.Unsafe as IO +import qualified App.Static.Base as S +import qualified App.Static.Posix as P +import qualified App.Static.Windows as W -homeDirectory :: FilePath -homeDirectory = IO.unsafePerformIO $ IO.getHomeDirectory -{-# NOINLINE homeDirectory #-} +cabalDirectory :: FilePath +cabalDirectory = if S.isPosix then P.cabalDirectory else W.cabalDirectory diff --git a/src/App/Static/Base.hs b/src/App/Static/Base.hs new file mode 100644 --- /dev/null +++ b/src/App/Static/Base.hs @@ -0,0 +1,13 @@ +module App.Static.Base where + +import qualified System.Directory as IO +import qualified System.IO.Unsafe as IO +import qualified System.Info as I + +homeDirectory :: FilePath +homeDirectory = IO.unsafePerformIO $ IO.getHomeDirectory +{-# NOINLINE homeDirectory #-} + +isPosix :: Bool +isPosix = I.os /= "mingw32" +{-# NOINLINE isPosix #-} diff --git a/src/App/Static/Posix.hs b/src/App/Static/Posix.hs new file mode 100644 --- /dev/null +++ b/src/App/Static/Posix.hs @@ -0,0 +1,8 @@ +module App.Static.Posix where + +import HaskellWorks.CabalCache.Location (()) + +import qualified App.Static.Base as S + +cabalDirectory :: FilePath +cabalDirectory = S.homeDirectory ".cabal" diff --git a/src/App/Static/Windows.hs b/src/App/Static/Windows.hs new file mode 100644 --- /dev/null +++ b/src/App/Static/Windows.hs @@ -0,0 +1,15 @@ +module App.Static.Windows where + +import Data.Maybe +import HaskellWorks.CabalCache.Location (()) + +import qualified App.Static.Base as S +import qualified System.Environment as IO +import qualified System.IO.Unsafe as IO + +appDataDirectory :: FilePath +appDataDirectory = IO.unsafePerformIO $ fmap (fromMaybe S.homeDirectory) (IO.lookupEnv "APPDATA") +{-# NOINLINE appDataDirectory #-} + +cabalDirectory :: FilePath +cabalDirectory = appDataDirectory "cabal" diff --git a/src/HaskellWorks/CabalCache/Core.hs b/src/HaskellWorks/CabalCache/Core.hs --- a/src/HaskellWorks/CabalCache/Core.hs +++ b/src/HaskellWorks/CabalCache/Core.hs @@ -4,7 +4,9 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + module HaskellWorks.CabalCache.Core ( PackageInfo(..) , Tagged(..) @@ -18,25 +20,27 @@ import Control.DeepSeq (NFData) import Control.Lens hiding ((<.>)) import Control.Monad (forM) +import Control.Monad.Catch import Control.Monad.Except import Data.Aeson (eitherDecode) import Data.Bifunctor (first) import Data.Bool (bool) import Data.Generics.Product.Any (the) -import Data.Semigroup ((<>)) import Data.String import Data.Text (Text) import GHC.Generics (Generic) import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Error +import HaskellWorks.CabalCache.Show import System.FilePath ((<.>), ()) import qualified Data.ByteString.Lazy as LBS -import qualified Data.List as List +import qualified Data.List as L import qualified Data.Text as T import qualified HaskellWorks.CabalCache.IO.Tar as IO import qualified HaskellWorks.CabalCache.Types as Z import qualified System.Directory as IO +import qualified System.Process as IO type PackageDir = FilePath type ConfPath = FilePath @@ -57,12 +61,32 @@ , libs :: [Library] } deriving (Show, Eq, Generic, NFData) -mkCompilerContext :: MonadIO m => Z.PlanJson -> ExceptT Text m Z.CompilerContext +(<||>) :: Monad m => ExceptT e m a -> ExceptT e m a -> ExceptT e m a +(<||>) f g = f `catchError` const g + +findExecutable :: MonadIO m => Text -> ExceptT Text m Text +findExecutable exe = fmap T.pack $ + liftIO (IO.findExecutable (T.unpack exe)) >>= nothingToError (exe <> " is not in path") + +runGhcPkg :: (MonadIO m, MonadCatch m) => Text -> [Text] -> ExceptT Text m Text +runGhcPkg cmdExe args = catch (liftIO $ T.pack <$> IO.readProcess (T.unpack cmdExe) (fmap T.unpack args) "") $ + \(e :: IOError) -> throwError $ "Unable to run " <> cmdExe <> " " <> T.unwords args <> ": " <> tshow e + +verifyGhcPkgVersion :: (MonadIO m, MonadCatch m) => Text -> Text -> ExceptT Text m Text +verifyGhcPkgVersion version cmdExe = do + stdout <- runGhcPkg cmdExe ["--version"] + if T.isSuffixOf (" " <> version) (mconcat (L.take 1 (T.lines stdout))) + then return cmdExe + else throwError $ cmdExe <> "has is not of version " <> version + +mkCompilerContext :: (MonadIO m, MonadCatch m) => Z.PlanJson -> ExceptT Text m Z.CompilerContext mkCompilerContext plan = do compilerVersion <- T.stripPrefix "ghc-" (plan ^. the @"compilerId") & nothingToError "No compiler version available in plan" - let ghcPkgCmd = "ghc-pkg-" <> compilerVersion - ghcPkgCmdPath <- liftIO (IO.findExecutable (T.unpack ghcPkgCmd)) >>= nothingToError (ghcPkgCmd <> " is not in path") - return (Z.CompilerContext [ghcPkgCmdPath]) + let versionedGhcPkgCmd = "ghc-pkg-" <> compilerVersion + ghcPkgCmdPath <- + (findExecutable versionedGhcPkgCmd >>= verifyGhcPkgVersion compilerVersion) + <||> (findExecutable "ghc-pkg" >>= verifyGhcPkgVersion compilerVersion) + return (Z.CompilerContext [T.unpack ghcPkgCmdPath]) relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup] relativePaths basePath pInfo = @@ -107,5 +131,5 @@ getLibFiles relativeLibPath libPath libPrefix = do libExists <- IO.doesDirectoryExist libPath if libExists - then fmap (relativeLibPath ) . filter (List.isPrefixOf (T.unpack libPrefix)) <$> IO.listDirectory libPath + then fmap (relativeLibPath ) . filter (L.isPrefixOf (T.unpack libPrefix)) <$> IO.listDirectory libPath else pure [] diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs --- a/src/HaskellWorks/CabalCache/IO/Lazy.hs +++ b/src/HaskellWorks/CabalCache/IO/Lazy.hs @@ -27,7 +27,6 @@ import HaskellWorks.CabalCache.Show import qualified Antiope.S3.Lazy as AWS -import qualified Antiope.S3.Types as AWS import qualified Control.Concurrent as IO import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T @@ -43,9 +42,9 @@ import qualified System.IO as IO import qualified System.IO.Error as IO -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant bracket" -} handleAwsError :: MonadCatch m => m a -> m (Either AppError a) handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) -> diff --git a/test/HaskellWorks/CabalCache/AwsSpec.hs b/test/HaskellWorks/CabalCache/AwsSpec.hs --- a/test/HaskellWorks/CabalCache/AwsSpec.hs +++ b/test/HaskellWorks/CabalCache/AwsSpec.hs @@ -22,9 +22,9 @@ import qualified Network.HTTP.Types as HTTP import qualified System.Environment as IO -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant bracket" -} spec :: Spec spec = describe "HaskellWorks.CabalCache.QuerySpec" $ do diff --git a/test/HaskellWorks/CabalCache/LocationSpec.hs b/test/HaskellWorks/CabalCache/LocationSpec.hs --- a/test/HaskellWorks/CabalCache/LocationSpec.hs +++ b/test/HaskellWorks/CabalCache/LocationSpec.hs @@ -18,9 +18,9 @@ import qualified Hedgehog.Range as Range import qualified System.FilePath as FP -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant bracket" -} s3Uri :: MonadGen m => m S3Uri s3Uri = do diff --git a/test/HaskellWorks/CabalCache/QuerySpec.hs b/test/HaskellWorks/CabalCache/QuerySpec.hs --- a/test/HaskellWorks/CabalCache/QuerySpec.hs +++ b/test/HaskellWorks/CabalCache/QuerySpec.hs @@ -16,9 +16,9 @@ import qualified Data.ByteString.Lazy as LBS import qualified HaskellWorks.CabalCache.Types as Z -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant bracket" -} spec :: Spec spec = describe "HaskellWorks.Assist.QuerySpec" $ do