Restructure modules
This commit is contained in:
parent
c56b9ec3ce
commit
2845425099
GPG Key ID:
3786C5262ECB4A3F
@ -13,9 +13,10 @@ import GHCup.Errors
|
||||
import GHCup.Types.Optics ( getDirs )
|
||||
import GHCup.Types hiding ( LeanAppState(..) )
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude ( decUTF8Safe )
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Prelude ( decUTF8Safe )
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
|
||||
import Brick
|
||||
import Brick.Widgets.Border
|
||||
|
||||
@ -12,9 +12,11 @@ module GHCup.OptParse.ChangeLog where
|
||||
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.Prelude.Process (exec)
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@ -34,8 +36,6 @@ import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import Data.Versions
|
||||
import URI.ByteString (serializeURIRef')
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.File (exec)
|
||||
import Data.Char (toLower)
|
||||
|
||||
|
||||
|
||||
@ -16,10 +16,10 @@ import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.MegaParsec
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Concurrent
|
||||
|
||||
@ -13,13 +13,12 @@ module GHCup.OptParse.Compile where
|
||||
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -7,7 +7,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
|
||||
module GHCup.OptParse.Config where
|
||||
|
||||
@ -15,9 +14,9 @@ module GHCup.OptParse.Config where
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
|
||||
@ -17,9 +17,10 @@ import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Version
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@ -36,7 +37,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Utils.File
|
||||
import Language.Haskell.TH
|
||||
|
||||
|
||||
|
||||
@ -14,8 +14,8 @@ module GHCup.OptParse.GC where
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -19,8 +19,8 @@ import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Codec.Archive
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
|
||||
@ -11,7 +11,7 @@ module GHCup.OptParse.List where
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
|
||||
@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude.Logger
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -14,10 +14,10 @@ module GHCup.OptParse.Prefetch where
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -18,9 +18,9 @@ import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -10,14 +10,17 @@ module GHCup.OptParse.Run where
|
||||
|
||||
import GHCup
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.File
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
#ifdef IS_WINDOWS
|
||||
import GHCup.Prelude.Process
|
||||
#endif
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Control.Exception.Safe ( MonadMask, MonadCatch )
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
|
||||
@ -17,8 +17,8 @@ import GHCup.OptParse.Common
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -11,8 +11,8 @@ module GHCup.OptParse.ToolRequirements where
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@ -30,7 +30,7 @@ import qualified Data.Text.IO as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Platform
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Prelude
|
||||
import GHCup.Requirements
|
||||
import System.IO
|
||||
|
||||
|
||||
@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -14,7 +14,8 @@ module GHCup.OptParse.Upgrade where
|
||||
import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -18,8 +18,8 @@ import GHCup.Errors
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
@ -22,9 +22,9 @@ import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics hiding ( toolRequirements )
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.Version
|
||||
|
||||
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
|
||||
|
||||
40
ghcup.cabal
40
ghcup.cabal
@ -44,31 +44,39 @@ flag internal-downloader
|
||||
manual: True
|
||||
|
||||
flag no-exe
|
||||
description: Don't build any executables
|
||||
description: Don't build any executables
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
GHCup
|
||||
GHCup.Cabal
|
||||
GHCup.Download
|
||||
GHCup.Download.Utils
|
||||
GHCup.Errors
|
||||
GHCup.GHC
|
||||
GHCup.HLS
|
||||
GHCup.List
|
||||
GHCup.Platform
|
||||
GHCup.Prelude
|
||||
GHCup.Prelude.File
|
||||
GHCup.Prelude.File.Search
|
||||
GHCup.Prelude.Internal
|
||||
GHCup.Prelude.Logger
|
||||
GHCup.Prelude.Logger.Internal
|
||||
GHCup.Prelude.MegaParsec
|
||||
GHCup.Prelude.Process
|
||||
GHCup.Prelude.String.QQ
|
||||
GHCup.Prelude.Version.QQ
|
||||
GHCup.Requirements
|
||||
GHCup.Stack
|
||||
GHCup.Types
|
||||
GHCup.Types.JSON
|
||||
GHCup.Types.JSON.Utils
|
||||
GHCup.Types.Optics
|
||||
GHCup.Utils
|
||||
GHCup.Utils.Dirs
|
||||
GHCup.Utils.File
|
||||
GHCup.Utils.File.Common
|
||||
GHCup.Utils.Logger
|
||||
GHCup.Utils.MegaParsec
|
||||
GHCup.Utils.Prelude
|
||||
GHCup.Utils.String.QQ
|
||||
GHCup.Utils.Version.QQ
|
||||
GHCup.Version
|
||||
|
||||
hs-source-dirs: lib
|
||||
@ -155,9 +163,9 @@ library
|
||||
if os(windows)
|
||||
cpp-options: -DIS_WINDOWS
|
||||
other-modules:
|
||||
GHCup.Utils.File.Windows
|
||||
GHCup.Utils.Prelude.Windows
|
||||
GHCup.Utils.Windows
|
||||
GHCup.Prelude.File.Windows
|
||||
GHCup.Prelude.Process.Windows
|
||||
GHCup.Prelude.Windows
|
||||
|
||||
build-depends:
|
||||
, bzlib
|
||||
@ -166,11 +174,11 @@ library
|
||||
|
||||
else
|
||||
other-modules:
|
||||
GHCup.Utils.File.Posix
|
||||
GHCup.Utils.File.Posix.Foreign
|
||||
GHCup.Utils.File.Posix.Traversals
|
||||
GHCup.Utils.Posix
|
||||
GHCup.Utils.Prelude.Posix
|
||||
GHCup.Prelude.File.Posix
|
||||
GHCup.Prelude.File.Posix.Foreign
|
||||
GHCup.Prelude.File.Posix.Traversals
|
||||
GHCup.Prelude.Posix
|
||||
GHCup.Prelude.Process.Posix
|
||||
|
||||
c-sources: cbits/dirutils.c
|
||||
build-depends:
|
||||
|
||||
2508
lib/GHCup.hs
2508
lib/GHCup.hs
File diff suppressed because it is too large
Load Diff
279
lib/GHCup/Cabal.hs
Normal file
279
lib/GHCup/Cabal.hs
Normal file
@ -0,0 +1,279 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Cabal
|
||||
Description : GHCup installation functions for Cabal
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Cabal where
|
||||
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
|
||||
import Codec.Archive ( ArchiveResult )
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Versions hiding ( patch )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import Safe hiding ( at )
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Tool installation ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installCabalBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> InstallDir
|
||||
-> Bool -- ^ Force install
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBindist dlinfo ver installDir forceInstall = do
|
||||
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
|
||||
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
-- check if we already have a regular cabal already installed
|
||||
regularCabalInstalled <- lift $ cabalInstalled ver
|
||||
|
||||
if
|
||||
| not forceInstall
|
||||
, regularCabalInstalled
|
||||
, GHCupInternal <- installDir -> do
|
||||
throwE $ AlreadyInstalled Cabal ver
|
||||
|
||||
| forceInstall
|
||||
, regularCabalInstalled
|
||||
, GHCupInternal <- installDir -> do
|
||||
lift $ logInfo "Removing the currently installed version first!"
|
||||
liftE $ rmCabalVer ver
|
||||
|
||||
| otherwise -> pure ()
|
||||
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
case installDir of
|
||||
IsolateDir isoDir -> do -- isolated install
|
||||
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
|
||||
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||
|
||||
GHCupInternal -> do -- regular install
|
||||
liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall
|
||||
|
||||
|
||||
-- | Install an unpacked cabal distribution.Symbol
|
||||
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
|
||||
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> InstallDirResolved -- ^ Path to install to
|
||||
-> Version
|
||||
-> Bool -- ^ Force Install
|
||||
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
|
||||
installCabalUnpacked path inst ver forceInstall = do
|
||||
lift $ logInfo "Installing cabal"
|
||||
let cabalFile = "cabal"
|
||||
liftIO $ createDirRecursive' (fromInstallDir inst)
|
||||
let destFileName = cabalFile
|
||||
<> (case inst of
|
||||
IsolateDirResolved _ -> ""
|
||||
_ -> ("-" <>) . T.unpack . prettyVer $ ver
|
||||
)
|
||||
<> exeExt
|
||||
let destPath = fromInstallDir inst </> destFileName
|
||||
|
||||
copyFileE
|
||||
(path </> cabalFile <> exeExt)
|
||||
destPath
|
||||
(not forceInstall)
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
|
||||
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
|
||||
-- the latest installed version.
|
||||
installCabalBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
-> InstallDir
|
||||
-> Bool -- force install
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBin ver installDir forceInstall = do
|
||||
dlinfo <- liftE $ getDownloadInfo Cabal ver
|
||||
installCabalBindist dlinfo ver installDir forceInstall
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Set cabal ]--
|
||||
-----------------
|
||||
|
||||
|
||||
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
|
||||
setCabal :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setCabal ver = do
|
||||
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
|
||||
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
|
||||
-- create link
|
||||
let destL = targetFile
|
||||
lift $ createLink destL cabalbin
|
||||
|
||||
pure ()
|
||||
|
||||
unsetCabal :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m)
|
||||
=> m ()
|
||||
unsetCabal = do
|
||||
Dirs {..} <- getDirs
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
hideError doesNotExistErrorType $ rmLink cabalbin
|
||||
|
||||
|
||||
----------------
|
||||
--[ Rm cabal ]--
|
||||
----------------
|
||||
|
||||
|
||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||
-- after removal (e.g. setting it to an older version).
|
||||
rmCabalVer :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmCabalVer ver = do
|
||||
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))
|
||||
|
||||
cSet <- lift cabalSet
|
||||
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
|
||||
|
||||
when (Just ver == cSet) $ do
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
case headMay . reverse . sort $ cVers of
|
||||
Just latestver -> setCabal latestver
|
||||
Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)
|
||||
@ -34,9 +34,10 @@ import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
@ -10,7 +10,7 @@ module GHCup.Download.IOStreams where
|
||||
import GHCup.Download.Utils
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
|
||||
@ -10,7 +10,7 @@ module GHCup.Download.Utils where
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
|
||||
1078
lib/GHCup/GHC.hs
Normal file
1078
lib/GHCup/GHC.hs
Normal file
File diff suppressed because it is too large
Load Diff
620
lib/GHCup/HLS.hs
Normal file
620
lib/GHCup/HLS.hs
Normal file
@ -0,0 +1,620 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.HLS
|
||||
Description : GHCup installation functions for HLS
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.HLS where
|
||||
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Codec.Archive ( ArchiveResult )
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String ( fromString )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions hiding ( patch )
|
||||
import Distribution.Types.Version hiding ( Version )
|
||||
import Distribution.Types.PackageId
|
||||
import Distribution.Types.PackageDescription
|
||||
import Distribution.Types.GenericPackageDescription
|
||||
import Distribution.PackageDescription.Parsec
|
||||
import GHC.IO.Exception
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import Safe hiding ( at )
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.Regex.Posix
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ Installation ]--
|
||||
--------------------
|
||||
|
||||
|
||||
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installHLSBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> InstallDir -- ^ isolated install path, if user passed any
|
||||
-> Bool -- ^ Force install
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, FileAlreadyExistsError
|
||||
, ProcessError
|
||||
, DirNotEmpty
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
]
|
||||
m
|
||||
()
|
||||
installHLSBindist dlinfo ver installDir forceInstall = do
|
||||
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
|
||||
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
regularHLSInstalled <- lift $ hlsInstalled ver
|
||||
|
||||
if
|
||||
| not forceInstall
|
||||
, regularHLSInstalled
|
||||
, GHCupInternal <- installDir -> do -- regular install
|
||||
throwE $ AlreadyInstalled HLS ver
|
||||
|
||||
| forceInstall
|
||||
, regularHLSInstalled
|
||||
, GHCupInternal <- installDir -> do -- regular forced install
|
||||
lift $ logInfo "Removing the currently installed version of HLS before force installing!"
|
||||
liftE $ rmHLSVer ver
|
||||
|
||||
| otherwise -> pure ()
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
legacy <- liftIO $ isLegacyHLSBindist workdir
|
||||
|
||||
if
|
||||
| not forceInstall
|
||||
, not legacy
|
||||
, (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)
|
||||
| otherwise -> pure ()
|
||||
|
||||
case installDir of
|
||||
IsolateDir isoDir -> do
|
||||
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
|
||||
if legacy
|
||||
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||
else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||
|
||||
GHCupInternal -> do
|
||||
if legacy
|
||||
then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall
|
||||
else do
|
||||
inst <- ghcupHLSDir ver
|
||||
liftE $ runBuildAction tmpUnpack
|
||||
$ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall
|
||||
liftE $ setHLS ver SetHLS_XYZ Nothing
|
||||
|
||||
|
||||
isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
|
||||
-> IO Bool
|
||||
isLegacyHLSBindist path = do
|
||||
not <$> doesFileExist (path </> "GNUmakefile")
|
||||
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLSUnpacked :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadReader env m
|
||||
, MonadFail m
|
||||
, HasLog env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadResource m
|
||||
, HasPlatformReq env
|
||||
)
|
||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> InstallDirResolved -- ^ Path to install to
|
||||
-> Version
|
||||
-> Bool
|
||||
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()
|
||||
installHLSUnpacked path inst ver forceInstall = do
|
||||
PlatformRequest { .. } <- lift getPlatformReq
|
||||
lift $ logInfo "Installing HLS"
|
||||
tmpInstallDest <- lift withGHCupTmpDir
|
||||
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
|
||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)
|
||||
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
|
||||
inst
|
||||
HLS
|
||||
(mkTVer ver)
|
||||
(\f t -> liftIO $ do
|
||||
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
|
||||
install f t (not forceInstall)
|
||||
forM_ mtime $ setModificationTime t)
|
||||
|
||||
-- | Install an unpacked hls distribution (legacy).
|
||||
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> InstallDirResolved -- ^ Path to install to
|
||||
-> Version
|
||||
-> Bool -- ^ is it a force install
|
||||
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
|
||||
installHLSUnpackedLegacy path installDir ver forceInstall = do
|
||||
lift $ logInfo "Installing HLS"
|
||||
liftIO $ createDirRecursive' (fromInstallDir installDir)
|
||||
|
||||
-- install haskell-language-server-<ghcver>
|
||||
bins@(_:_) <- liftIO $ findFiles
|
||||
path
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
|
||||
)
|
||||
forM_ bins $ \f -> do
|
||||
let toF = dropSuffix exeExt f
|
||||
<> (case installDir of
|
||||
IsolateDirResolved _ -> ""
|
||||
_ -> ("~" <>) . T.unpack . prettyVer $ ver
|
||||
)
|
||||
<> exeExt
|
||||
|
||||
let srcPath = path </> f
|
||||
let destPath = fromInstallDir installDir </> toF
|
||||
|
||||
-- destination could be an existing symlink
|
||||
-- for new make-based HLSes
|
||||
liftIO $ rmFileForce destPath
|
||||
|
||||
copyFileE
|
||||
srcPath
|
||||
destPath
|
||||
(not forceInstall)
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
-- install haskell-language-server-wrapper
|
||||
let wrapper = "haskell-language-server-wrapper"
|
||||
toF = wrapper
|
||||
<> (case installDir of
|
||||
IsolateDirResolved _ -> ""
|
||||
_ -> ("-" <>) . T.unpack . prettyVer $ ver
|
||||
)
|
||||
<> exeExt
|
||||
srcWrapperPath = path </> wrapper <> exeExt
|
||||
destWrapperPath = fromInstallDir installDir </> toF
|
||||
|
||||
liftIO $ rmFileForce destWrapperPath
|
||||
copyFileE
|
||||
srcWrapperPath
|
||||
destWrapperPath
|
||||
(not forceInstall)
|
||||
|
||||
lift $ chmod_755 destWrapperPath
|
||||
|
||||
|
||||
|
||||
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
||||
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
||||
installHLSBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
-> InstallDir
|
||||
-> Bool -- force install
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, FileAlreadyExistsError
|
||||
, ProcessError
|
||||
, DirNotEmpty
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
]
|
||||
m
|
||||
()
|
||||
installHLSBin ver installDir forceInstall = do
|
||||
dlinfo <- liftE $ getDownloadInfo HLS ver
|
||||
installHLSBindist dlinfo ver installDir forceInstall
|
||||
|
||||
|
||||
compileHLS :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Either Version GitBranch
|
||||
-> [Version]
|
||||
-> Maybe Int
|
||||
-> Maybe Version
|
||||
-> InstallDir
|
||||
-> Maybe (Either FilePath URI)
|
||||
-> Maybe URI
|
||||
-> Maybe (Either FilePath [URI]) -- ^ patches
|
||||
-> [Text] -- ^ additional args to cabal install
|
||||
-> Excepts '[ NoDownload
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, DigestError
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, BuildFailed
|
||||
, NotInstalled
|
||||
] m Version
|
||||
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do
|
||||
PlatformRequest { .. } <- lift getPlatformReq
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
Dirs { .. } <- lift getDirs
|
||||
|
||||
|
||||
(workdir, tver) <- case targetHLS of
|
||||
-- unpack from version tarball
|
||||
Left tver -> do
|
||||
lift $ logDebug $ "Requested to compile: " <> prettyVer tver
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <-
|
||||
preview (ix HLS % ix tver % viSourceDL % _Just) dls
|
||||
?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||
|
||||
workdir <- maybe (pure tmpUnpack)
|
||||
(liftE . intoSubdir tmpUnpack)
|
||||
(view dlSubdir dlInfo)
|
||||
|
||||
pure (workdir, tver)
|
||||
|
||||
-- clone from git
|
||||
Right GitBranch{..} -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
||||
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
||||
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
|
||||
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||
lEM $ git [ "init" ]
|
||||
lEM $ git [ "remote"
|
||||
, "add"
|
||||
, "origin"
|
||||
, fromString rep ]
|
||||
|
||||
let fetch_args =
|
||||
[ "fetch"
|
||||
, "--depth"
|
||||
, "1"
|
||||
, "--quiet"
|
||||
, "origin"
|
||||
, fromString ref ]
|
||||
lEM $ git fetch_args
|
||||
|
||||
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
||||
(Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
|
||||
pure . (\c -> Version Nothing c [] Nothing)
|
||||
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
|
||||
. versionNumbers
|
||||
. pkgVersion
|
||||
. package
|
||||
. packageDescription
|
||||
$ gpd
|
||||
|
||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
|
||||
|
||||
pure (tmpUnpack, tver)
|
||||
|
||||
-- the version that's installed may differ from the
|
||||
-- compiled version, so the user can overwrite it
|
||||
let installVer = fromMaybe tver ov
|
||||
|
||||
liftE $ runBuildAction
|
||||
workdir
|
||||
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
|
||||
let tmpInstallDir = fromGHCupPath workdir </> "out"
|
||||
liftIO $ createDirRecursive' tmpInstallDir
|
||||
|
||||
-- apply patches
|
||||
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
|
||||
|
||||
-- set up project files
|
||||
cp <- case cabalProject of
|
||||
Just (Left cp)
|
||||
| isAbsolute cp -> do
|
||||
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
|
||||
pure "cabal.project"
|
||||
| otherwise -> pure (takeFileName cp)
|
||||
Just (Right uri) -> do
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False
|
||||
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
|
||||
pure "cabal.project"
|
||||
Nothing -> pure "cabal.project"
|
||||
forM_ cabalProjectLocal $ \uri -> do
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False
|
||||
copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
|
||||
artifacts <- forM (sort ghcs) $ \ghc -> do
|
||||
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
|
||||
liftIO $ createDirRecursive' tmpInstallDir
|
||||
lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
|
||||
liftE $ lEM @_ @'[ProcessError] $
|
||||
execLogged "cabal" ( [ "v2-install"
|
||||
, "-w"
|
||||
, "ghc-" <> T.unpack (prettyVer ghc)
|
||||
, "--install-method=copy"
|
||||
] ++
|
||||
maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
|
||||
[ "--overwrite-policy=always"
|
||||
, "--disable-profiling"
|
||||
, "--disable-tests"
|
||||
, "--installdir=" <> ghcInstallDir
|
||||
, "--project-file=" <> cp
|
||||
] ++ fmap T.unpack cabalArgs ++ [
|
||||
"exe:haskell-language-server"
|
||||
, "exe:haskell-language-server-wrapper"]
|
||||
)
|
||||
(Just $ fromGHCupPath workdir)
|
||||
"cabal"
|
||||
Nothing
|
||||
pure ghcInstallDir
|
||||
|
||||
forM_ artifacts $ \artifact -> do
|
||||
logInfo $ T.pack (show artifact)
|
||||
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
|
||||
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
|
||||
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
|
||||
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
|
||||
|
||||
case installDir of
|
||||
IsolateDir isoDir -> do
|
||||
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
|
||||
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
|
||||
GHCupInternal -> do
|
||||
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True
|
||||
)
|
||||
|
||||
pure installVer
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Set/Unset ]--
|
||||
-----------------
|
||||
|
||||
-- | Set the haskell-language-server symlinks.
|
||||
setHLS :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
, MonadFail m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> SetHLS
|
||||
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
|
||||
-- and don't want mess with other versions
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setHLS ver shls mBinDir = do
|
||||
whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
|
||||
|
||||
-- symlink destination
|
||||
binDir <- case mBinDir of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
Dirs {binDir = f} <- lift getDirs
|
||||
pure f
|
||||
|
||||
-- first delete the old symlinks
|
||||
when (isNothing mBinDir) $
|
||||
case shls of
|
||||
-- not for legacy
|
||||
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
|
||||
-- legacy and new
|
||||
SetHLSOnly -> liftE rmPlainHLS
|
||||
|
||||
case shls of
|
||||
-- not for legacy
|
||||
SetHLS_XYZ -> do
|
||||
bins <- lift $ hlsInternalServerScripts ver Nothing
|
||||
|
||||
forM_ bins $ \f -> do
|
||||
let fname = takeFileName f
|
||||
destL <- binarySymLinkDestination binDir f
|
||||
let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
|
||||
then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
|
||||
lift $ createLink destL (binDir </> target)
|
||||
|
||||
-- legacy and new
|
||||
SetHLSOnly -> do
|
||||
-- set haskell-language-server-<ghcver> symlinks
|
||||
bins <- lift $ hlsServerBinaries ver Nothing
|
||||
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
|
||||
|
||||
forM_ bins $ \f -> do
|
||||
let destL = f
|
||||
let target = (<> exeExt) . head . splitOn "~" $ f
|
||||
lift $ createLink destL (binDir </> target)
|
||||
|
||||
-- set haskell-language-server-wrapper symlink
|
||||
let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
|
||||
lift $ createLink destL wrapper
|
||||
|
||||
when (isNothing mBinDir) $
|
||||
lift warnAboutHlsCompatibility
|
||||
|
||||
|
||||
unsetHLS :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m)
|
||||
=> m ()
|
||||
unsetHLS = do
|
||||
Dirs {..} <- getDirs
|
||||
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles'
|
||||
binDir
|
||||
(MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof)
|
||||
forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir </>))
|
||||
hideError doesNotExistErrorType $ rmLink wrapper
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Removal ]--
|
||||
---------------
|
||||
|
||||
|
||||
-- | Delete a hls version. Will try to fix the hls symlinks
|
||||
-- after removal (e.g. setting it to an older version).
|
||||
rmHLSVer :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled, UninstallFailed] m ()
|
||||
rmHLSVer ver = do
|
||||
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
|
||||
|
||||
isHlsSet <- lift hlsSet
|
||||
|
||||
liftE $ rmMinorHLSSymlinks ver
|
||||
|
||||
when (Just ver == isHlsSet) $ do
|
||||
-- delete all set symlinks
|
||||
liftE rmPlainHLS
|
||||
|
||||
hlsDir' <- ghcupHLSDir ver
|
||||
let hlsDir = fromGHCupPath hlsDir'
|
||||
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
|
||||
Just files -> do
|
||||
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
|
||||
forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir </> dropDrive f))
|
||||
removeEmptyDirsRecursive hlsDir
|
||||
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir
|
||||
f <- recordedInstallationFile HLS (mkTVer ver)
|
||||
lift $ recycleFile f
|
||||
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
|
||||
Nothing -> do
|
||||
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
|
||||
recyclePathForcibly hlsDir'
|
||||
|
||||
when (Just ver == isHlsSet) $ do
|
||||
-- set latest hls
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
case headMay . reverse . sort $ hlsVers of
|
||||
Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
|
||||
Nothing -> pure ()
|
||||
410
lib/GHCup/List.hs
Normal file
410
lib/GHCup/List.hs
Normal file
@ -0,0 +1,410 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.List
|
||||
Description : Listing versions and tools
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.List where
|
||||
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions hiding ( patch )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ List tools ]--
|
||||
------------------
|
||||
|
||||
|
||||
-- | Filter data type for 'listVersions'.
|
||||
data ListCriteria = ListInstalled
|
||||
| ListSet
|
||||
| ListAvailable
|
||||
deriving Show
|
||||
|
||||
-- | A list result describes a single tool version
|
||||
-- and various of its properties.
|
||||
data ListResult = ListResult
|
||||
{ lTool :: Tool
|
||||
, lVer :: Version
|
||||
, lCross :: Maybe Text -- ^ currently only for GHC
|
||||
, lTag :: [Tag]
|
||||
, lInstalled :: Bool
|
||||
, lSet :: Bool -- ^ currently active version
|
||||
, fromSrc :: Bool -- ^ compiled from source
|
||||
, lStray :: Bool -- ^ not in download info
|
||||
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
|
||||
, hlsPowered :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
-- | Extract all available tool versions and their tags.
|
||||
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
|
||||
availableToolVersions av tool = view
|
||||
(at tool % non Map.empty)
|
||||
av
|
||||
|
||||
|
||||
-- | List all versions from the download info, as well as stray
|
||||
-- versions.
|
||||
listVersions :: ( MonadCatch m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
)
|
||||
=> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> m [ListResult]
|
||||
listVersions lt' criteria = do
|
||||
-- some annoying work to avoid too much repeated IO
|
||||
cSet <- cabalSet
|
||||
cabals <- getInstalledCabals
|
||||
hlsSet' <- hlsSet
|
||||
hlses <- getInstalledHLSs
|
||||
sSet <- stackSet
|
||||
stacks <- getInstalledStacks
|
||||
|
||||
go lt' cSet cabals hlsSet' hlses sSet stacks
|
||||
where
|
||||
go lt cSet cabals hlsSet' hlses sSet stacks = do
|
||||
case lt of
|
||||
Just t -> do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
||||
-- get versions from GHCupDownloads
|
||||
let avTools = availableToolVersions dls t
|
||||
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
|
||||
|
||||
case t of
|
||||
GHC -> do
|
||||
slr <- strayGHCs avTools
|
||||
pure (sort (slr ++ lr))
|
||||
Cabal -> do
|
||||
slr <- strayCabals avTools cSet cabals
|
||||
pure (sort (slr ++ lr))
|
||||
HLS -> do
|
||||
slr <- strayHLS avTools hlsSet' hlses
|
||||
pure (sort (slr ++ lr))
|
||||
Stack -> do
|
||||
slr <- strayStacks avTools sSet stacks
|
||||
pure (sort (slr ++ lr))
|
||||
GHCup -> do
|
||||
let cg = maybeToList $ currentGHCup avTools
|
||||
pure (sort (cg ++ lr))
|
||||
Nothing -> do
|
||||
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
|
||||
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
|
||||
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
|
||||
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
|
||||
stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
|
||||
pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
|
||||
strayGHCs :: ( MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version VersionInfo
|
||||
-> m [ListResult]
|
||||
strayGHCs avTools = do
|
||||
ghcs <- getInstalledGHCs
|
||||
fmap catMaybes $ forM ghcs $ \case
|
||||
Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do
|
||||
case Map.lookup _tvVersion avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = isNothing (Map.lookup _tvVersion avTools)
|
||||
, lNoBindist = False
|
||||
, ..
|
||||
}
|
||||
Right tver@GHCTargetVersion{ .. } -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
, lCross = _tvTarget
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = True -- NOTE: cross currently cannot be installed via bindist
|
||||
, lNoBindist = False
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
strayCabals :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version VersionInfo
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> m [ListResult]
|
||||
strayCabals avTools cSet cabals = do
|
||||
fmap catMaybes $ forM cabals $ \case
|
||||
Right ver ->
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
let lSet = cSet == Just ver
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = Cabal
|
||||
, lVer = ver
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = isNothing (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
strayHLS :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m)
|
||||
=> Map.Map Version VersionInfo
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> m [ListResult]
|
||||
strayHLS avTools hlsSet' hlss = do
|
||||
fmap catMaybes $ forM hlss $ \case
|
||||
Right ver ->
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
let lSet = hlsSet' == Just ver
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = HLS
|
||||
, lVer = ver
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = isNothing (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
strayStacks :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadCatch m
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
)
|
||||
=> Map.Map Version VersionInfo
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> m [ListResult]
|
||||
strayStacks avTools stackSet' stacks = do
|
||||
fmap catMaybes $ forM stacks $ \case
|
||||
Right ver ->
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
let lSet = stackSet' == Just ver
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = Stack
|
||||
, lVer = ver
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = isNothing (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Left e -> do
|
||||
logWarn
|
||||
$ "Could not parse version of stray directory" <> T.pack e
|
||||
pure Nothing
|
||||
|
||||
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
|
||||
currentGHCup av =
|
||||
let currentVer = fromJust $ pvpToVersion ghcUpVer ""
|
||||
listVer = Map.lookup currentVer av
|
||||
latestVer = fst <$> headOf (getTagged Latest) av
|
||||
recommendedVer = fst <$> headOf (getTagged Latest) av
|
||||
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
|
||||
in if | Map.member currentVer av -> Nothing
|
||||
| otherwise -> Just $ ListResult { lVer = currentVer
|
||||
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
|
||||
, lCross = Nothing
|
||||
, lTool = GHCup
|
||||
, fromSrc = False
|
||||
, lStray = isNothing listVer
|
||||
, lSet = True
|
||||
, lInstalled = True
|
||||
, lNoBindist = False
|
||||
, hlsPowered = False
|
||||
}
|
||||
|
||||
-- NOTE: this are not cross ones, because no bindists
|
||||
toListResult :: ( HasLog env
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasGHCupInfo env
|
||||
, HasPlatformReq env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Tool
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> (Version, VersionInfo)
|
||||
-> m ListResult
|
||||
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
|
||||
case t of
|
||||
GHC -> do
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
|
||||
let tver = mkTVer v
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
|
||||
lInstalled <- ghcInstalled tver
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem v) hlsGHCVersions
|
||||
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
|
||||
Cabal -> do
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
|
||||
let lSet = cSet == Just v
|
||||
let lInstalled = elem v $ rights cabals
|
||||
pure ListResult { lVer = v
|
||||
, lCross = Nothing
|
||||
, lTag = tags
|
||||
, lTool = t
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
GHCup -> do
|
||||
let lSet = prettyPVP ghcUpVer == prettyVer v
|
||||
let lInstalled = lSet
|
||||
pure ListResult { lVer = v
|
||||
, lTag = tags
|
||||
, lCross = Nothing
|
||||
, lTool = t
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, lNoBindist = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
HLS -> do
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v
|
||||
let lSet = hlsSet' == Just v
|
||||
let lInstalled = elem v $ rights hlses
|
||||
pure ListResult { lVer = v
|
||||
, lCross = Nothing
|
||||
, lTag = tags
|
||||
, lTool = t
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Stack -> do
|
||||
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v
|
||||
let lSet = stackSet' == Just v
|
||||
let lInstalled = elem v $ rights stacks
|
||||
pure ListResult { lVer = v
|
||||
, lCross = Nothing
|
||||
, lTag = tags
|
||||
, lTool = t
|
||||
, fromSrc = False
|
||||
, lStray = False
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
|
||||
|
||||
filter' :: [ListResult] -> [ListResult]
|
||||
filter' lr = case criteria of
|
||||
Nothing -> lr
|
||||
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
|
||||
Just ListSet -> filter (\ListResult {..} -> lSet) lr
|
||||
Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr
|
||||
|
||||
@ -24,10 +24,10 @@ import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
|
||||
54
lib/GHCup/Prelude.hs
Normal file
54
lib/GHCup/Prelude.hs
Normal file
@ -0,0 +1,54 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Prelude
|
||||
Description : MegaParsec utilities
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
GHCup specific prelude. Lots of Excepts functionality.
|
||||
-}
|
||||
module GHCup.Prelude
|
||||
(module GHCup.Prelude,
|
||||
module GHCup.Prelude.Internal,
|
||||
#if defined(IS_WINDOWS)
|
||||
module GHCup.Prelude.Windows
|
||||
#else
|
||||
module GHCup.Prelude.Posix
|
||||
#endif
|
||||
)
|
||||
where
|
||||
|
||||
import GHCup.Prelude.Internal
|
||||
import GHCup.Types.Optics (HasLog)
|
||||
import GHCup.Prelude.Logger (logWarn)
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Prelude.Windows
|
||||
#else
|
||||
import GHCup.Prelude.Posix
|
||||
#endif
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
-- for some obscure reason... this won't type-check if we move it to a different module
|
||||
catchWarn :: forall es m env . ( Pretty (V es)
|
||||
, MonadReader env m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, Monad m) => Excepts es m () -> Excepts '[] m ()
|
||||
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
|
||||
|
||||
@ -8,7 +8,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.Utils.File (
|
||||
module GHCup.Prelude.File (
|
||||
mergeFileTree,
|
||||
copyFileE,
|
||||
findFilesDeep,
|
||||
@ -19,12 +19,8 @@ module GHCup.Utils.File (
|
||||
getDirectoryContentsRecursiveBFSUnsafe,
|
||||
getDirectoryContentsRecursiveDFSUnsafe,
|
||||
recordedInstallationFile,
|
||||
module GHCup.Utils.File.Common,
|
||||
module GHCup.Prelude.File.Search,
|
||||
|
||||
executeOut,
|
||||
execLogged,
|
||||
exec,
|
||||
toProcessError,
|
||||
chmod_755,
|
||||
isBrokenSymlink,
|
||||
copyFile,
|
||||
@ -41,25 +37,38 @@ module GHCup.Utils.File (
|
||||
rmFile,
|
||||
rmDirectoryLink,
|
||||
moveFilePortable,
|
||||
moveFile
|
||||
moveFile,
|
||||
rmPathForcibly,
|
||||
|
||||
exeExt,
|
||||
exeExt',
|
||||
getLinkTarget,
|
||||
pathIsLink,
|
||||
rmLink,
|
||||
createLink
|
||||
) where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Prelude.Logger.Internal (logInfo, logDebug)
|
||||
import GHCup.Prelude.Internal
|
||||
import GHCup.Prelude.File.Search
|
||||
#if IS_WINDOWS
|
||||
import GHCup.Utils.File.Windows
|
||||
import GHCup.Prelude.File.Windows
|
||||
import GHCup.Prelude.Windows
|
||||
#else
|
||||
import GHCup.Utils.File.Posix
|
||||
import GHCup.Prelude.File.Posix
|
||||
import GHCup.Prelude.Posix
|
||||
#endif
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Text.Regex.Posix
|
||||
import Control.Monad.IO.Unlift ( MonadUnliftIO )
|
||||
import Control.Exception.Safe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString ( ByteString )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import System.FilePath
|
||||
import Text.PrettyPrint.HughesPJClass (prettyShow)
|
||||
|
||||
@ -69,7 +78,6 @@ import Control.DeepSeq (force)
|
||||
import Control.Exception (evaluate)
|
||||
import GHC.IO.Exception
|
||||
import System.IO.Error
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
|
||||
-- | Merge one file tree to another given a copy operation.
|
||||
@ -338,3 +346,81 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
|
||||
rmDirectoryLink fp
|
||||
| isWindows = recover (liftIO $ removeDirectoryLink fp)
|
||||
| otherwise = liftIO $ removeDirectoryLink fp
|
||||
|
||||
|
||||
rmPathForcibly :: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupPath
|
||||
-> m ()
|
||||
rmPathForcibly fp
|
||||
| isWindows = recover (liftIO $ removePathForcibly fp)
|
||||
| otherwise = liftIO $ removePathForcibly fp
|
||||
|
||||
|
||||
-- | The file extension for executables.
|
||||
exeExt :: String
|
||||
exeExt
|
||||
| isWindows = ".exe"
|
||||
| otherwise = ""
|
||||
|
||||
-- | The file extension for executables.
|
||||
exeExt' :: ByteString
|
||||
exeExt'
|
||||
| isWindows = ".exe"
|
||||
| otherwise = ""
|
||||
|
||||
|
||||
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
|
||||
rmLink fp
|
||||
| isWindows = do
|
||||
hideError doesNotExistErrorType . recycleFile $ fp
|
||||
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
|
||||
| otherwise = hideError doesNotExistErrorType . recycleFile $ fp
|
||||
|
||||
|
||||
-- | Creates a symbolic link on unix and a fake symlink on windows for
|
||||
-- executables, which:
|
||||
-- 1. is a shim exe
|
||||
-- 2. has a corresponding .shim file in the same directory that
|
||||
-- contains the target
|
||||
--
|
||||
-- This overwrites previously existing files.
|
||||
--
|
||||
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
|
||||
createLink :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> FilePath -- ^ path to the target executable
|
||||
-> FilePath -- ^ path to be created
|
||||
-> m ()
|
||||
createLink link exe
|
||||
| isWindows = do
|
||||
dirs <- getDirs
|
||||
let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
|
||||
|
||||
let shim = dropExtension exe <.> "shim"
|
||||
-- For hardlinks, link needs to be absolute.
|
||||
-- If link is relative, it's relative to the target exe.
|
||||
-- Note that (</>) drops lhs when rhs is absolute.
|
||||
fullLink = takeDirectory exe </> link
|
||||
shimContents = "path = " <> fullLink
|
||||
|
||||
logDebug $ "rm -f " <> T.pack exe
|
||||
rmLink exe
|
||||
|
||||
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
|
||||
liftIO $ copyFile shimGen exe False
|
||||
liftIO $ writeFile shim shimContents
|
||||
| otherwise = do
|
||||
logDebug $ "rm -f " <> T.pack exe
|
||||
hideError doesNotExistErrorType $ recycleFile exe
|
||||
|
||||
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
|
||||
liftIO $ createFileLink link exe
|
||||
324
lib/GHCup/Prelude/File/Posix.hs
Normal file
324
lib/GHCup/Prelude/File/Posix.hs
Normal file
@ -0,0 +1,324 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE CApiFFI #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File.Posix
|
||||
Description : File and directory handling for unix
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Prelude.File.Posix where
|
||||
|
||||
import GHCup.Prelude.File.Posix.Traversals
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad.Reader
|
||||
import Foreign.C.String
|
||||
import Foreign.C.Error
|
||||
import Foreign.C.Types
|
||||
import System.IO ( hClose, hSetBinaryMode )
|
||||
import System.IO.Error hiding ( catchIOError )
|
||||
import System.FilePath
|
||||
import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist )
|
||||
import System.Posix.Directory
|
||||
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
||||
import System.Posix.Internals ( withFilePath )
|
||||
import System.Posix.Files
|
||||
import System.Posix.Types
|
||||
|
||||
|
||||
import qualified System.Posix.Directory as PD
|
||||
import qualified System.Posix.Files as PF
|
||||
import qualified System.Posix.IO as SPI
|
||||
import qualified System.Posix as Posix
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.FileSystem.Handle
|
||||
as IFH
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified GHCup.Prelude.File.Posix.Foreign as FD
|
||||
import qualified Streamly.Internal.Data.Stream.StreamD.Type
|
||||
as D
|
||||
import Streamly.Internal.Data.Unfold.Type
|
||||
import qualified Streamly.Internal.Data.Unfold as U
|
||||
import Streamly.Internal.Control.Concurrent ( withRunInIO )
|
||||
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
|
||||
|
||||
|
||||
-- | On unix, we can use symlinks, so we just get the
|
||||
-- symbolic link target.
|
||||
--
|
||||
-- On windows, we have to emulate symlinks via shims,
|
||||
-- see 'createLink'.
|
||||
getLinkTarget :: FilePath -> IO FilePath
|
||||
getLinkTarget = getSymbolicLinkTarget
|
||||
|
||||
|
||||
-- | Checks whether the path is a link.
|
||||
pathIsLink :: FilePath -> IO Bool
|
||||
pathIsLink = pathIsSymbolicLink
|
||||
|
||||
|
||||
chmod_755 :: MonadIO m => FilePath -> m ()
|
||||
chmod_755 fp = do
|
||||
let exe_mode =
|
||||
nullFileMode
|
||||
`unionFileModes` ownerExecuteMode
|
||||
`unionFileModes` ownerReadMode
|
||||
`unionFileModes` ownerWriteMode
|
||||
`unionFileModes` groupExecuteMode
|
||||
`unionFileModes` groupReadMode
|
||||
`unionFileModes` otherExecuteMode
|
||||
`unionFileModes` otherReadMode
|
||||
liftIO $ setFileMode fp exe_mode
|
||||
|
||||
|
||||
-- |Default permissions for a new file.
|
||||
newFilePerms :: FileMode
|
||||
newFilePerms =
|
||||
ownerWriteMode
|
||||
`unionFileModes` ownerReadMode
|
||||
`unionFileModes` groupWriteMode
|
||||
`unionFileModes` groupReadMode
|
||||
`unionFileModes` otherWriteMode
|
||||
`unionFileModes` otherReadMode
|
||||
|
||||
|
||||
-- | Checks whether the binary is a broken link.
|
||||
isBrokenSymlink :: FilePath -> IO Bool
|
||||
isBrokenSymlink fp = do
|
||||
try (pathIsSymbolicLink fp) >>= \case
|
||||
Right True -> do
|
||||
let symDir = takeDirectory fp
|
||||
tfp <- getSymbolicLinkTarget fp
|
||||
not <$> doesPathExist
|
||||
-- this drops 'symDir' if 'tfp' is absolute
|
||||
(symDir </> tfp)
|
||||
Right b -> pure b
|
||||
Left e | isDoesNotExistError e -> pure False
|
||||
| otherwise -> throwIO e
|
||||
|
||||
copyFile :: FilePath -- ^ source file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if file exists
|
||||
-> IO ()
|
||||
copyFile from to fail' = do
|
||||
bracket
|
||||
(openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)
|
||||
(hClose . snd)
|
||||
$ \(fromFd, fH) -> do
|
||||
sourceFileMode <- fileMode <$> getFdStatus fromFd
|
||||
let dflags = [ FD.oNofollow
|
||||
, if fail' then FD.oExcl else FD.oTrunc
|
||||
]
|
||||
bracket
|
||||
(openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
|
||||
(hClose . snd)
|
||||
$ \(_, tH) -> do
|
||||
hSetBinaryMode fH True
|
||||
hSetBinaryMode tH True
|
||||
streamlyCopy (fH, tH)
|
||||
where
|
||||
openFdHandle fp omode flags fM = do
|
||||
fd <- openFd' fp omode flags fM
|
||||
handle' <- SPI.fdToHandle fd
|
||||
pure (fd, handle')
|
||||
streamlyCopy (fH, tH) =
|
||||
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
|
||||
|
||||
foreign import capi unsafe "fcntl.h open"
|
||||
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
|
||||
|
||||
|
||||
open_ :: CString
|
||||
-> Posix.OpenMode
|
||||
-> [FD.Flags]
|
||||
-> Maybe Posix.FileMode
|
||||
-> IO Posix.Fd
|
||||
open_ str how optional_flags maybe_mode = do
|
||||
fd <- c_open str all_flags mode_w
|
||||
return (Posix.Fd fd)
|
||||
where
|
||||
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
|
||||
|
||||
|
||||
(creat, mode_w) = case maybe_mode of
|
||||
Nothing -> ([],0)
|
||||
Just x -> ([FD.oCreat], x)
|
||||
|
||||
open_mode = case how of
|
||||
Posix.ReadOnly -> FD.oRdonly
|
||||
Posix.WriteOnly -> FD.oWronly
|
||||
Posix.ReadWrite -> FD.oRdwr
|
||||
|
||||
|
||||
-- |Open and optionally create this file. See 'System.Posix.Files'
|
||||
-- for information on how to use the 'FileMode' type.
|
||||
--
|
||||
-- Note that passing @Just x@ as the 4th argument triggers the
|
||||
-- `oCreat` status flag, which must be set when you pass in `oExcl`
|
||||
-- to the status flags. Also see the manpage for @open(2)@.
|
||||
openFd' :: FilePath
|
||||
-> Posix.OpenMode
|
||||
-> [FD.Flags] -- ^ status flags of @open(2)@
|
||||
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
|
||||
-> IO Posix.Fd
|
||||
openFd' name how optional_flags maybe_mode =
|
||||
withFilePath name $ \str ->
|
||||
throwErrnoPathIfMinus1Retry "openFd" name $
|
||||
open_ str how optional_flags maybe_mode
|
||||
|
||||
|
||||
-- |Deletes the given file. Raises `eISDIR`
|
||||
-- if run on a directory. Does not follow symbolic links.
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `InappropriateType` for wrong file type (directory)
|
||||
-- - `NoSuchThing` if the file does not exist
|
||||
-- - `PermissionDenied` if the directory cannot be read
|
||||
--
|
||||
-- Notes: calls `unlink`
|
||||
deleteFile :: FilePath -> IO ()
|
||||
deleteFile = removeLink
|
||||
|
||||
|
||||
-- |Recreate a symlink.
|
||||
--
|
||||
-- In `Overwrite` copy mode only files and empty directories are deleted.
|
||||
--
|
||||
-- Safety/reliability concerns:
|
||||
--
|
||||
-- * `Overwrite` mode is inherently non-atomic
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `InvalidArgument` if source file is wrong type (not a symlink)
|
||||
-- - `PermissionDenied` if output directory cannot be written to
|
||||
-- - `PermissionDenied` if source directory cannot be opened
|
||||
-- - `SameFile` if source and destination are the same file
|
||||
-- (`HPathIOException`)
|
||||
--
|
||||
--
|
||||
-- Throws in `Strict` mode only:
|
||||
--
|
||||
-- - `AlreadyExists` if destination already exists
|
||||
--
|
||||
-- Throws in `Overwrite` mode only:
|
||||
--
|
||||
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
|
||||
--
|
||||
-- Notes:
|
||||
--
|
||||
-- - calls `symlink`
|
||||
recreateSymlink :: FilePath -- ^ the old symlink file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if destination file exists
|
||||
-> IO ()
|
||||
recreateSymlink symsource newsym fail' = do
|
||||
sympoint <- readSymbolicLink symsource
|
||||
case fail' of
|
||||
True -> pure ()
|
||||
False ->
|
||||
handleIO (\e -> if doesNotExistErrorType == ioeGetErrorType e then pure () else liftIO . ioError $ e) $ deleteFile newsym
|
||||
createSymbolicLink sympoint newsym
|
||||
|
||||
|
||||
-- copys files, recreates symlinks, fails on all other types
|
||||
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||
install from to fail' = do
|
||||
fs <- PF.getSymbolicLinkStatus from
|
||||
decide fs
|
||||
where
|
||||
decide fs | PF.isRegularFile fs = copyFile from to fail'
|
||||
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
||||
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
||||
|
||||
moveFile :: FilePath -> FilePath -> IO ()
|
||||
moveFile = rename
|
||||
|
||||
|
||||
moveFilePortable :: FilePath -> FilePath -> IO ()
|
||||
moveFilePortable from to = do
|
||||
catchErrno [eXDEV] (moveFile from to) $ do
|
||||
copyFile from to True
|
||||
removeFile from
|
||||
|
||||
|
||||
catchErrno :: [Errno] -- ^ errno to catch
|
||||
-> IO a -- ^ action to try, which can raise an IOException
|
||||
-> IO a -- ^ action to carry out in case of an IOException and
|
||||
-- if errno matches
|
||||
-> IO a
|
||||
catchErrno en a1 a2 =
|
||||
catchIOError a1 $ \e -> do
|
||||
errno <- getErrno
|
||||
if errno `elem` en
|
||||
then a2
|
||||
else ioError e
|
||||
|
||||
removeEmptyDirectory :: FilePath -> IO ()
|
||||
removeEmptyDirectory = PD.removeDirectory
|
||||
|
||||
|
||||
-- | Create an 'Unfold' of directory contents.
|
||||
unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)
|
||||
unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step dirstream = do
|
||||
(typ, e) <- liftIO $ readDirEnt dirstream
|
||||
return $ if
|
||||
| null e -> D.Stop
|
||||
| "." == e -> D.Skip dirstream
|
||||
| ".." == e -> D.Skip dirstream
|
||||
| otherwise -> D.Yield (typ, e) dirstream
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveDFSUnsafe fp = go ""
|
||||
where
|
||||
go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
|
||||
if | t == FD.dtDir -> go (cd </> f)
|
||||
| otherwise -> pure (cd </> f)
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath
|
||||
getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""]))
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step (_, Nothing, []) = return D.Stop
|
||||
|
||||
step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do
|
||||
(dt, f) <- liftIO $ readDirEnt dirstream
|
||||
if | FD.dtUnknown == dt -> do
|
||||
runIOFinalizer finalizer
|
||||
return $ D.Skip (topdir, Nothing, dirs)
|
||||
| f == "." || f == ".."
|
||||
-> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs)
|
||||
| FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir </> f):dirs)
|
||||
| otherwise -> return $ D.Yield (cdir </> f) (topdir, Just (cdir, dirstream, finalizer), dirs)
|
||||
|
||||
step (topdir, Nothing, dir:dirs) = do
|
||||
(s, f) <- acquire (topdir </> dir)
|
||||
return $ D.Skip (topdir, Just (dir, s, f), dirs)
|
||||
|
||||
acquire dir =
|
||||
withRunInIO $ \run -> mask_ $ run $ do
|
||||
dirstream <- liftIO $ openDirStream dir
|
||||
ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)
|
||||
return (dirstream, ref)
|
||||
|
||||
getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
|
||||
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module GHCup.Utils.File.Posix.Foreign where
|
||||
module GHCup.Prelude.File.Posix.Foreign where
|
||||
|
||||
import Data.Bits
|
||||
import Data.List (foldl')
|
||||
@ -7,7 +7,7 @@
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
|
||||
module GHCup.Utils.File.Posix.Traversals (
|
||||
module GHCup.Prelude.File.Posix.Traversals (
|
||||
-- lower-level stuff
|
||||
readDirEnt
|
||||
, unpackDirStream
|
||||
@ -17,7 +17,7 @@ module GHCup.Utils.File.Posix.Traversals (
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import GHCup.Utils.File.Posix.Foreign
|
||||
import GHCup.Prelude.File.Posix.Foreign
|
||||
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
import Foreign.C.Error
|
||||
@ -2,13 +2,12 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module GHCup.Utils.File.Common (
|
||||
module GHCup.Utils.File.Common
|
||||
module GHCup.Prelude.File.Search (
|
||||
module GHCup.Prelude.File.Search
|
||||
, ProcessError(..)
|
||||
, CapturedProcess(..)
|
||||
) where
|
||||
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types(ProcessError(..), CapturedProcess(..))
|
||||
|
||||
import Control.Monad.Reader
|
||||
@ -27,6 +26,8 @@ import Text.Regex.Posix
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Megaparsec as MP
|
||||
import Control.Exception.Safe (handleIO)
|
||||
import System.Directory.Internal.Prelude (ioeGetErrorType)
|
||||
|
||||
|
||||
|
||||
@ -38,7 +39,7 @@ searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
|
||||
handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e)
|
||||
$ do
|
||||
contents <- listDirectory x
|
||||
findM (isMatch x) contents >>= \case
|
||||
@ -52,6 +53,12 @@ searchPath paths needle = go paths
|
||||
isExecutable :: FilePath -> IO Bool
|
||||
isExecutable file = executable <$> getPermissions file
|
||||
|
||||
-- TODO: inlined from GHCup.Prelude
|
||||
findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
|
||||
ifM ~b ~t ~f = do
|
||||
b' <- b
|
||||
if b' then t else f
|
||||
|
||||
|
||||
-- | Check wether a binary is shadowed by another one that comes before
|
||||
-- it in PATH. Returns the path to said binary, if any.
|
||||
@ -106,7 +113,3 @@ findFiles' path parser = do
|
||||
pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents
|
||||
|
||||
|
||||
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
|
||||
checkFileAlreadyExists fp = liftIO $ doesFileExist fp
|
||||
|
||||
|
||||
@ -4,48 +4,28 @@
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File.Windows
|
||||
Description : File and windows APIs
|
||||
Description : File and directory handling for windows
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : Windows
|
||||
|
||||
This module handles file and executable handling.
|
||||
Some of these functions use sophisticated logging.
|
||||
-}
|
||||
module GHCup.Utils.File.Windows where
|
||||
module GHCup.Prelude.File.Windows where
|
||||
|
||||
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Prelude.Internal
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.List
|
||||
import Foreign.C.Error
|
||||
import GHC.IO.Exception
|
||||
import GHC.IO.Handle
|
||||
import qualified GHC.Unicode as U
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import qualified System.IO.Error as IOE
|
||||
import System.Process
|
||||
|
||||
import qualified System.Win32.Info as WS
|
||||
import qualified System.Win32.File as WS
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Streamly.Internal.Data.Stream.StreamD.Type
|
||||
as D
|
||||
@ -58,188 +38,23 @@ import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFin
|
||||
|
||||
|
||||
|
||||
toProcessError :: FilePath
|
||||
-> [FilePath]
|
||||
-> ExitCode
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args exitcode = case exitcode of
|
||||
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
|
||||
ExitSuccess -> Right ()
|
||||
|
||||
|
||||
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
|
||||
-- lets you pass 'CreateProcess' giving better flexibility.
|
||||
-- | On unix, we can use symlinks, so we just get the
|
||||
-- symbolic link target.
|
||||
--
|
||||
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
|
||||
-- record will be ignored.
|
||||
--
|
||||
-- @since 1.2.3.0
|
||||
readCreateProcessWithExitCodeBS
|
||||
:: CreateProcess
|
||||
-> BL.ByteString
|
||||
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
|
||||
readCreateProcessWithExitCodeBS cp input = do
|
||||
let cp_opts = cp {
|
||||
std_in = CreatePipe,
|
||||
std_out = CreatePipe,
|
||||
std_err = CreatePipe
|
||||
}
|
||||
withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
|
||||
\mb_inh mb_outh mb_errh ph ->
|
||||
case (mb_inh, mb_outh, mb_errh) of
|
||||
(Just inh, Just outh, Just errh) -> do
|
||||
|
||||
out <- BS.hGetContents outh
|
||||
err <- BS.hGetContents errh
|
||||
|
||||
-- fork off threads to start consuming stdout & stderr
|
||||
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
|
||||
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
|
||||
|
||||
-- now write any input
|
||||
unless (BL.null input) $
|
||||
ignoreSigPipe $ BL.hPut inh input
|
||||
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
|
||||
ignoreSigPipe $ hClose inh
|
||||
|
||||
-- wait on the output
|
||||
waitOut
|
||||
waitErr
|
||||
|
||||
hClose outh
|
||||
hClose errh
|
||||
|
||||
-- wait on the process
|
||||
ex <- waitForProcess ph
|
||||
return (ex, BL.fromStrict out, BL.fromStrict err)
|
||||
|
||||
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
|
||||
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
|
||||
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
|
||||
where
|
||||
ignoreSigPipe :: IO () -> IO ()
|
||||
ignoreSigPipe = EX.handle $ \e -> case e of
|
||||
IOError { ioe_type = ResourceVanished
|
||||
, ioe_errno = Just ioe }
|
||||
| Errno ioe == ePIPE -> return ()
|
||||
_ -> throwIO e
|
||||
-- wrapper so we can get exceptions with the appropriate function name.
|
||||
withCreateProcess_
|
||||
:: String
|
||||
-> CreateProcess
|
||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||
-> IO a
|
||||
withCreateProcess_ fun c action =
|
||||
EX.bracketOnError (createProcess_ fun c) cleanupProcess
|
||||
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
|
||||
|
||||
-- | Fork a thread while doing something else, but kill it if there's an
|
||||
-- exception.
|
||||
--
|
||||
-- This is important in the cases above because we want to kill the thread
|
||||
-- that is holding the Handle lock, because when we clean up the process we
|
||||
-- try to close that handle, which could otherwise deadlock.
|
||||
--
|
||||
withForkWait :: IO () -> (IO () -> IO a) -> IO a
|
||||
withForkWait async' body = do
|
||||
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
|
||||
mask $ \restore -> do
|
||||
tid <- forkIO $ try (restore async') >>= putMVar waitVar
|
||||
let wait' = takeMVar waitVar >>= either throwIO return
|
||||
restore (body wait') `EX.onException` killThread tid
|
||||
-- On windows, we have to emulate symlinks via shims,
|
||||
-- see 'createLink'.
|
||||
getLinkTarget :: FilePath -> IO FilePath
|
||||
getLinkTarget fp = do
|
||||
content <- readFile (dropExtension fp <.> "shim")
|
||||
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
|
||||
pure $ stripNewline $ dropPrefix "path = " p
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: MonadIO m
|
||||
=> FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> m CapturedProcess
|
||||
executeOut path args chdir = do
|
||||
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
|
||||
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
|
||||
pure $ CapturedProcess exit out err
|
||||
-- | Checks whether the path is a link.
|
||||
pathIsLink :: FilePath -> IO Bool
|
||||
pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
|
||||
|
||||
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> FilePath -- ^ log filename (opened in append mode)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
Dirs {..} <- getDirs
|
||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||
let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
|
||||
cp <- createProcessWithMingwPath ((proc exe args)
|
||||
{ cwd = chdir
|
||||
, env = env
|
||||
, std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
})
|
||||
fmap (toProcessError exe args)
|
||||
$ liftIO
|
||||
$ withCreateProcess cp
|
||||
$ \_ mout merr ph ->
|
||||
case (mout, merr) of
|
||||
(Just cStdout, Just cStderr) -> do
|
||||
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
|
||||
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
|
||||
waitOut
|
||||
waitErr
|
||||
waitForProcess ph
|
||||
_ -> fail "Could not acquire out/err handle"
|
||||
|
||||
where
|
||||
tee :: FilePath -> Handle -> IO ()
|
||||
tee logFile handle' = go
|
||||
where
|
||||
go = do
|
||||
some <- BS.hGetSome handle' 512
|
||||
if BS.null some
|
||||
then pure ()
|
||||
else do
|
||||
void $ BS.appendFile logFile some
|
||||
-- subprocess stdout also goes to stderr for logging
|
||||
void $ BS.hPut stderr some
|
||||
go
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
exec exe args chdir env = do
|
||||
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError exe args exit_code
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
execShell :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execShell exe args chdir env = do
|
||||
let cmd = exe <> " " <> concatMap (' ':) args
|
||||
cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError cmd [] exit_code
|
||||
|
||||
|
||||
chmod_755 :: MonadIO m => FilePath -> m ()
|
||||
chmod_755 fp =
|
||||
@ -247,30 +62,6 @@ chmod_755 fp =
|
||||
in liftIO $ setPermissions fp perm
|
||||
|
||||
|
||||
createProcessWithMingwPath :: MonadIO m
|
||||
=> CreateProcess
|
||||
-> m CreateProcess
|
||||
createProcessWithMingwPath cp = do
|
||||
msys2Dir <- liftIO ghcupMsys2Dir
|
||||
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
|
||||
let mingWPaths = [msys2Dir </> "usr" </> "bin"
|
||||
,msys2Dir </> "mingw64" </> "bin"]
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
envWithNewPath = Map.insert "Path" newPath envWithoutPath
|
||||
liftIO $ setEnv "Path" newPath
|
||||
pure $ cp { env = Just $ Map.toList envWithNewPath }
|
||||
|
||||
ghcupMsys2Dir :: IO FilePath
|
||||
ghcupMsys2Dir =
|
||||
lookupEnv "GHCUP_MSYS2" >>= \case
|
||||
Just fp -> pure fp
|
||||
Nothing -> do
|
||||
baseDir <- liftIO ghcupBaseDir
|
||||
pure (fromGHCupPath baseDir </> "msys64")
|
||||
|
||||
-- | Checks whether the binary is a broken link.
|
||||
isBrokenSymlink :: FilePath -> IO Bool
|
||||
isBrokenSymlink fp = do
|
||||
@ -7,7 +7,7 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Prelude
|
||||
Module : GHCup.Prelude.Internal
|
||||
Description : MegaParsec utilities
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
@ -15,28 +15,11 @@ Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
GHCup specific prelude. Lots of Excepts functionality.
|
||||
Stuff that doesn't need GHCup modules, so we can avoid
|
||||
recursive imports.
|
||||
-}
|
||||
module GHCup.Utils.Prelude
|
||||
(module GHCup.Utils.Prelude,
|
||||
#if defined(IS_WINDOWS)
|
||||
module GHCup.Utils.Prelude.Windows
|
||||
#else
|
||||
module GHCup.Utils.Prelude.Posix
|
||||
#endif
|
||||
)
|
||||
where
|
||||
module GHCup.Prelude.Internal where
|
||||
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory)
|
||||
import GHCup.Types
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import {-# SOURCE #-} GHCup.Utils.Logger (logWarn)
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Utils.Prelude.Windows
|
||||
#else
|
||||
import GHCup.Utils.Prelude.Posix
|
||||
#endif
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
@ -45,23 +28,15 @@ import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
|
||||
import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
|
||||
import Data.Maybe
|
||||
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Word8 hiding ( isDigit )
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
||||
import System.IO.Error
|
||||
import System.Directory hiding ( removeDirectory
|
||||
, removeDirectoryRecursive
|
||||
, removePathForcibly
|
||||
, copyFile
|
||||
)
|
||||
import System.FilePath
|
||||
|
||||
import Control.Retry
|
||||
import GHC.IO.Exception
|
||||
@ -70,7 +45,6 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import qualified Data.List.Split as Split
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Encoding.Error as E
|
||||
@ -184,13 +158,6 @@ lEM' :: forall e' e es a m
|
||||
-> Excepts es m a
|
||||
lEM' f em = lift em >>= lE . first f
|
||||
|
||||
-- for some obscure reason... this won't type-check if we move it to a different module
|
||||
catchWarn :: forall es m env . ( Pretty (V es)
|
||||
, MonadReader env m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, Monad m) => Excepts es m () -> Excepts '[] m ()
|
||||
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
|
||||
|
||||
fromEither :: Either a b -> VEither '[a] b
|
||||
fromEither = either (VLeft . V) VRight
|
||||
@ -311,56 +278,6 @@ intToText :: Integral a => a -> T.Text
|
||||
intToText = TL.toStrict . B.toLazyText . B.decimal
|
||||
|
||||
|
||||
pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
|
||||
pvpToVersion pvp_ rest =
|
||||
either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_
|
||||
|
||||
-- | Convert a version to a PVP and unparsable rest.
|
||||
--
|
||||
-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
|
||||
versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
|
||||
versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
|
||||
versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v
|
||||
where
|
||||
alternative :: MonadThrow m => Version -> m PVP
|
||||
alternative v' = case NE.takeWhile isDigit (_vChunks v') of
|
||||
[] -> throwM $ ParseError "Couldn't convert Version to PVP"
|
||||
xs -> pure $ pvpFromList (unsafeDigit <$> xs)
|
||||
|
||||
rest :: Version -> Text
|
||||
rest (Version _ cs pr me) =
|
||||
let chunks = NE.dropWhile isDigit cs
|
||||
ver = intersperse (T.pack ".") . chunksAsT $ chunks
|
||||
me' = maybe [] (\m -> [T.pack "+",m]) me
|
||||
pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
|
||||
prefix = case (ver, pr', me') of
|
||||
(_:_, _, _) -> T.pack "."
|
||||
_ -> T.pack ""
|
||||
in prefix <> mconcat (ver <> pr' <> me')
|
||||
where
|
||||
chunksAsT :: Functor t => t VChunk -> t Text
|
||||
chunksAsT = fmap (foldMap f)
|
||||
where
|
||||
f :: VUnit -> Text
|
||||
f (Digits i) = T.pack $ show i
|
||||
f (Str s) = s
|
||||
|
||||
foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
|
||||
foldable d g f | null f = d
|
||||
| otherwise = g f
|
||||
|
||||
|
||||
|
||||
isDigit :: VChunk -> Bool
|
||||
isDigit (Digits _ :| []) = True
|
||||
isDigit _ = False
|
||||
|
||||
unsafeDigit :: VChunk -> Int
|
||||
unsafeDigit (Digits x :| []) = fromIntegral x
|
||||
unsafeDigit _ = error "unsafeDigit: wrong input"
|
||||
|
||||
pvpFromList :: [Int] -> PVP
|
||||
pvpFromList = PVP . NE.fromList . fmap fromIntegral
|
||||
|
||||
-- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
|
||||
-- the Unicode replacement character U+FFFD.
|
||||
61
lib/GHCup/Prelude/Logger.hs
Normal file
61
lib/GHCup/Prelude/Logger.hs
Normal file
@ -0,0 +1,61 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Logger
|
||||
Description : logger definition
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
Here we define our main logger.
|
||||
-}
|
||||
module GHCup.Prelude.Logger
|
||||
( module GHCup.Prelude.Logger
|
||||
, module GHCup.Prelude.Logger.Internal
|
||||
)
|
||||
where
|
||||
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.Dirs (fromGHCupPath)
|
||||
import GHCup.Prelude.Internal
|
||||
import GHCup.Prelude.File.Search (findFiles)
|
||||
import GHCup.Prelude.File (recycleFile)
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
|
||||
|
||||
initGHCupFileLogging :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
) => m FilePath
|
||||
initGHCupFileLogging = do
|
||||
Dirs { logsDir } <- getDirs
|
||||
let logfile = fromGHCupPath logsDir </> "ghcup.log"
|
||||
logFiles <- liftIO $ findFiles
|
||||
(fromGHCupPath logsDir)
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^.*\.log$|] :: B.ByteString)
|
||||
)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
|
||||
|
||||
liftIO $ writeFile logfile ""
|
||||
pure logfile
|
||||
@ -3,7 +3,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Logger
|
||||
Module : GHCup.Utils.Logger.Internal
|
||||
Description : logger definition
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
@ -11,18 +11,13 @@ Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
Here we define our main logger.
|
||||
Breaking import cycles.
|
||||
-}
|
||||
module GHCup.Utils.Logger where
|
||||
module GHCup.Prelude.Logger.Internal where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
|
||||
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
|
||||
import {-# SOURCE #-} GHCup.Utils.File (recycleFile)
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
@ -30,12 +25,7 @@ import Data.Text ( Text )
|
||||
import Optics
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Console.Pretty
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import GHCup.Utils.Prelude
|
||||
import qualified Data.Text as T
|
||||
|
||||
logInfo :: ( MonadReader env m
|
||||
@ -93,7 +83,7 @@ logInternal logLevel msg = do
|
||||
let strs = T.split (== '\n') msg
|
||||
let out = case strs of
|
||||
[] -> T.empty
|
||||
(x:xs) ->
|
||||
(x:xs) ->
|
||||
foldr (\a b -> a <> "\n" <> b) mempty
|
||||
. ((l <> " " <> x) :)
|
||||
. fmap (\line' -> style' "[ ... ] " <> line' )
|
||||
@ -111,22 +101,3 @@ logInternal logLevel msg = do
|
||||
let outr = lr <> " " <> msg <> "\n"
|
||||
liftIO $ fileOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
) => m FilePath
|
||||
initGHCupFileLogging = do
|
||||
Dirs { logsDir } <- getDirs
|
||||
let logfile = fromGHCupPath logsDir </> "ghcup.log"
|
||||
logFiles <- liftIO $ findFiles
|
||||
(fromGHCupPath logsDir)
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^.*\.log$|] :: B.ByteString)
|
||||
)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
|
||||
|
||||
liftIO $ writeFile logfile ""
|
||||
pure logfile
|
||||
@ -10,7 +10,7 @@ Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.MegaParsec where
|
||||
module GHCup.Prelude.MegaParsec where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
module GHCup.Utils.Posix where
|
||||
module GHCup.Prelude.Posix where
|
||||
|
||||
|
||||
-- | Enables ANSI support on windows, does nothing on unix.
|
||||
@ -12,3 +12,8 @@ module GHCup.Utils.Posix where
|
||||
enableAnsiSupport :: IO (Either String Bool)
|
||||
enableAnsiSupport = pure (Right True)
|
||||
|
||||
isWindows, isNotWindows :: Bool
|
||||
isWindows = False
|
||||
isNotWindows = not isWindows
|
||||
|
||||
|
||||
25
lib/GHCup/Prelude/Process.hs
Normal file
25
lib/GHCup/Prelude/Process.hs
Normal file
@ -0,0 +1,25 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Process
|
||||
Description : Process handling
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Prelude.Process (
|
||||
executeOut,
|
||||
execLogged,
|
||||
exec,
|
||||
toProcessError,
|
||||
) where
|
||||
|
||||
|
||||
#if IS_WINDOWS
|
||||
import GHCup.Prelude.Process.Windows
|
||||
#else
|
||||
import GHCup.Prelude.Process.Posix
|
||||
#endif
|
||||
|
||||
@ -6,25 +6,22 @@
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File.Posix
|
||||
Description : File and unix APIs
|
||||
Description : Process handling for unix
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
This module handles file and executable handling.
|
||||
Some of these functions use sophisticated logging.
|
||||
-}
|
||||
module GHCup.Utils.File.Posix where
|
||||
module GHCup.Prelude.Process.Posix where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.File.Posix
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.File.Posix.Traversals
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
@ -39,17 +36,11 @@ import Data.IORef
|
||||
import Data.Sequence ( Seq, (|>) )
|
||||
import Data.List
|
||||
import Data.Word8
|
||||
import Foreign.C.String
|
||||
import Foreign.C.Error
|
||||
import Foreign.C.Types
|
||||
import GHC.IO.Exception
|
||||
import System.IO ( stderr, hClose, hSetBinaryMode )
|
||||
import System.IO ( stderr )
|
||||
import System.IO.Error hiding ( catchIOError )
|
||||
import System.FilePath
|
||||
import System.Posix.Directory
|
||||
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
||||
import System.Posix.Internals ( withFilePath )
|
||||
import System.Posix.Files
|
||||
import System.Posix.IO
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
@ -59,27 +50,12 @@ import qualified Control.Exception as EX
|
||||
import qualified Data.Sequence as Sq
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.Posix.Directory as PD
|
||||
import qualified System.Posix.Files as PF
|
||||
import qualified System.Posix.Process as SPP
|
||||
import qualified System.Posix.IO as SPI
|
||||
import qualified System.Console.Terminal.Size as TP
|
||||
import qualified System.Posix as Posix
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.FileSystem.Handle
|
||||
as IFH
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified GHCup.Utils.File.Posix.Foreign as FD
|
||||
import qualified Streamly.Internal.Data.Stream.StreamD.Type
|
||||
as D
|
||||
import Streamly.Internal.Data.Unfold.Type
|
||||
import qualified Streamly.Internal.Data.Unfold as U
|
||||
import Streamly.Internal.Control.Concurrent ( withRunInIO )
|
||||
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
|
||||
|
||||
|
||||
|
||||
@ -384,262 +360,3 @@ toProcessError exe args mps = case mps of
|
||||
|
||||
|
||||
|
||||
chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
|
||||
chmod_755 fp = do
|
||||
let exe_mode =
|
||||
nullFileMode
|
||||
`unionFileModes` ownerExecuteMode
|
||||
`unionFileModes` ownerReadMode
|
||||
`unionFileModes` ownerWriteMode
|
||||
`unionFileModes` groupExecuteMode
|
||||
`unionFileModes` groupReadMode
|
||||
`unionFileModes` otherExecuteMode
|
||||
`unionFileModes` otherReadMode
|
||||
logDebug ("chmod 755 " <> T.pack fp)
|
||||
liftIO $ setFileMode fp exe_mode
|
||||
|
||||
|
||||
-- |Default permissions for a new file.
|
||||
newFilePerms :: FileMode
|
||||
newFilePerms =
|
||||
ownerWriteMode
|
||||
`unionFileModes` ownerReadMode
|
||||
`unionFileModes` groupWriteMode
|
||||
`unionFileModes` groupReadMode
|
||||
`unionFileModes` otherWriteMode
|
||||
`unionFileModes` otherReadMode
|
||||
|
||||
|
||||
-- | Checks whether the binary is a broken link.
|
||||
isBrokenSymlink :: FilePath -> IO Bool
|
||||
isBrokenSymlink fp = do
|
||||
try (pathIsSymbolicLink fp) >>= \case
|
||||
Right True -> do
|
||||
let symDir = takeDirectory fp
|
||||
tfp <- getSymbolicLinkTarget fp
|
||||
not <$> doesPathExist
|
||||
-- this drops 'symDir' if 'tfp' is absolute
|
||||
(symDir </> tfp)
|
||||
Right b -> pure b
|
||||
Left e | isDoesNotExistError e -> pure False
|
||||
| otherwise -> throwIO e
|
||||
|
||||
copyFile :: FilePath -- ^ source file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if file exists
|
||||
-> IO ()
|
||||
copyFile from to fail' = do
|
||||
bracket
|
||||
(openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)
|
||||
(hClose . snd)
|
||||
$ \(fromFd, fH) -> do
|
||||
sourceFileMode <- fileMode <$> getFdStatus fromFd
|
||||
let dflags = [ FD.oNofollow
|
||||
, if fail' then FD.oExcl else FD.oTrunc
|
||||
]
|
||||
bracket
|
||||
(openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
|
||||
(hClose . snd)
|
||||
$ \(_, tH) -> do
|
||||
hSetBinaryMode fH True
|
||||
hSetBinaryMode tH True
|
||||
streamlyCopy (fH, tH)
|
||||
where
|
||||
openFdHandle fp omode flags fM = do
|
||||
fd <- openFd' fp omode flags fM
|
||||
handle' <- SPI.fdToHandle fd
|
||||
pure (fd, handle')
|
||||
streamlyCopy (fH, tH) =
|
||||
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
|
||||
|
||||
foreign import capi unsafe "fcntl.h open"
|
||||
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
|
||||
|
||||
|
||||
open_ :: CString
|
||||
-> Posix.OpenMode
|
||||
-> [FD.Flags]
|
||||
-> Maybe Posix.FileMode
|
||||
-> IO Posix.Fd
|
||||
open_ str how optional_flags maybe_mode = do
|
||||
fd <- c_open str all_flags mode_w
|
||||
return (Posix.Fd fd)
|
||||
where
|
||||
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
|
||||
|
||||
|
||||
(creat, mode_w) = case maybe_mode of
|
||||
Nothing -> ([],0)
|
||||
Just x -> ([FD.oCreat], x)
|
||||
|
||||
open_mode = case how of
|
||||
Posix.ReadOnly -> FD.oRdonly
|
||||
Posix.WriteOnly -> FD.oWronly
|
||||
Posix.ReadWrite -> FD.oRdwr
|
||||
|
||||
|
||||
-- |Open and optionally create this file. See 'System.Posix.Files'
|
||||
-- for information on how to use the 'FileMode' type.
|
||||
--
|
||||
-- Note that passing @Just x@ as the 4th argument triggers the
|
||||
-- `oCreat` status flag, which must be set when you pass in `oExcl`
|
||||
-- to the status flags. Also see the manpage for @open(2)@.
|
||||
openFd' :: FilePath
|
||||
-> Posix.OpenMode
|
||||
-> [FD.Flags] -- ^ status flags of @open(2)@
|
||||
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
|
||||
-> IO Posix.Fd
|
||||
openFd' name how optional_flags maybe_mode =
|
||||
withFilePath name $ \str ->
|
||||
throwErrnoPathIfMinus1Retry "openFd" name $
|
||||
open_ str how optional_flags maybe_mode
|
||||
|
||||
|
||||
-- |Deletes the given file. Raises `eISDIR`
|
||||
-- if run on a directory. Does not follow symbolic links.
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `InappropriateType` for wrong file type (directory)
|
||||
-- - `NoSuchThing` if the file does not exist
|
||||
-- - `PermissionDenied` if the directory cannot be read
|
||||
--
|
||||
-- Notes: calls `unlink`
|
||||
deleteFile :: FilePath -> IO ()
|
||||
deleteFile = removeLink
|
||||
|
||||
|
||||
-- |Recreate a symlink.
|
||||
--
|
||||
-- In `Overwrite` copy mode only files and empty directories are deleted.
|
||||
--
|
||||
-- Safety/reliability concerns:
|
||||
--
|
||||
-- * `Overwrite` mode is inherently non-atomic
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `InvalidArgument` if source file is wrong type (not a symlink)
|
||||
-- - `PermissionDenied` if output directory cannot be written to
|
||||
-- - `PermissionDenied` if source directory cannot be opened
|
||||
-- - `SameFile` if source and destination are the same file
|
||||
-- (`HPathIOException`)
|
||||
--
|
||||
--
|
||||
-- Throws in `Strict` mode only:
|
||||
--
|
||||
-- - `AlreadyExists` if destination already exists
|
||||
--
|
||||
-- Throws in `Overwrite` mode only:
|
||||
--
|
||||
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
|
||||
--
|
||||
-- Notes:
|
||||
--
|
||||
-- - calls `symlink`
|
||||
recreateSymlink :: FilePath -- ^ the old symlink file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if destination file exists
|
||||
-> IO ()
|
||||
recreateSymlink symsource newsym fail' = do
|
||||
sympoint <- readSymbolicLink symsource
|
||||
case fail' of
|
||||
True -> pure ()
|
||||
False ->
|
||||
hideError doesNotExistErrorType $ deleteFile newsym
|
||||
createSymbolicLink sympoint newsym
|
||||
|
||||
|
||||
-- copys files, recreates symlinks, fails on all other types
|
||||
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||
install from to fail' = do
|
||||
fs <- PF.getSymbolicLinkStatus from
|
||||
decide fs
|
||||
where
|
||||
decide fs | PF.isRegularFile fs = copyFile from to fail'
|
||||
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
||||
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
||||
|
||||
moveFile :: FilePath -> FilePath -> IO ()
|
||||
moveFile = rename
|
||||
|
||||
|
||||
moveFilePortable :: FilePath -> FilePath -> IO ()
|
||||
moveFilePortable from to = do
|
||||
catchErrno [eXDEV] (moveFile from to) $ do
|
||||
copyFile from to True
|
||||
removeFile from
|
||||
|
||||
|
||||
catchErrno :: [Errno] -- ^ errno to catch
|
||||
-> IO a -- ^ action to try, which can raise an IOException
|
||||
-> IO a -- ^ action to carry out in case of an IOException and
|
||||
-- if errno matches
|
||||
-> IO a
|
||||
catchErrno en a1 a2 =
|
||||
catchIOError a1 $ \e -> do
|
||||
errno <- getErrno
|
||||
if errno `elem` en
|
||||
then a2
|
||||
else ioError e
|
||||
|
||||
removeEmptyDirectory :: FilePath -> IO ()
|
||||
removeEmptyDirectory = PD.removeDirectory
|
||||
|
||||
|
||||
-- | Create an 'Unfold' of directory contents.
|
||||
unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)
|
||||
unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step dirstream = do
|
||||
(typ, e) <- liftIO $ readDirEnt dirstream
|
||||
return $ if
|
||||
| null e -> D.Stop
|
||||
| "." == e -> D.Skip dirstream
|
||||
| ".." == e -> D.Skip dirstream
|
||||
| otherwise -> D.Yield (typ, e) dirstream
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveDFSUnsafe fp = go ""
|
||||
where
|
||||
go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
|
||||
if | t == FD.dtDir -> go (cd </> f)
|
||||
| otherwise -> pure (cd </> f)
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath
|
||||
getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""]))
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step (_, Nothing, []) = return D.Stop
|
||||
|
||||
step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do
|
||||
(dt, f) <- liftIO $ readDirEnt dirstream
|
||||
if | FD.dtUnknown == dt -> do
|
||||
runIOFinalizer finalizer
|
||||
return $ D.Skip (topdir, Nothing, dirs)
|
||||
| f == "." || f == ".."
|
||||
-> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs)
|
||||
| FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir </> f):dirs)
|
||||
| otherwise -> return $ D.Yield (cdir </> f) (topdir, Just (cdir, dirstream, finalizer), dirs)
|
||||
|
||||
step (topdir, Nothing, dir:dirs) = do
|
||||
(s, f) <- acquire (topdir </> dir)
|
||||
return $ D.Skip (topdir, Just (dir, s, f), dirs)
|
||||
|
||||
acquire dir =
|
||||
withRunInIO $ \run -> mask_ $ run $ do
|
||||
dirstream <- liftIO $ openDirStream dir
|
||||
ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)
|
||||
return (dirstream, ref)
|
||||
|
||||
getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
|
||||
|
||||
|
||||
251
lib/GHCup/Prelude/Process/Windows.hs
Normal file
251
lib/GHCup/Prelude/Process/Windows.hs
Normal file
@ -0,0 +1,251 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Process.Windows
|
||||
Description : Process handling for windows
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : Windows
|
||||
-}
|
||||
module GHCup.Prelude.Process.Windows where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude.File.Search
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.List
|
||||
import Foreign.C.Error
|
||||
import GHC.IO.Exception
|
||||
import GHC.IO.Handle
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import System.Process
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
|
||||
toProcessError :: FilePath
|
||||
-> [FilePath]
|
||||
-> ExitCode
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args exitcode = case exitcode of
|
||||
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
|
||||
ExitSuccess -> Right ()
|
||||
|
||||
|
||||
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
|
||||
-- lets you pass 'CreateProcess' giving better flexibility.
|
||||
--
|
||||
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
|
||||
-- record will be ignored.
|
||||
--
|
||||
-- @since 1.2.3.0
|
||||
readCreateProcessWithExitCodeBS
|
||||
:: CreateProcess
|
||||
-> BL.ByteString
|
||||
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
|
||||
readCreateProcessWithExitCodeBS cp input = do
|
||||
let cp_opts = cp {
|
||||
std_in = CreatePipe,
|
||||
std_out = CreatePipe,
|
||||
std_err = CreatePipe
|
||||
}
|
||||
withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
|
||||
\mb_inh mb_outh mb_errh ph ->
|
||||
case (mb_inh, mb_outh, mb_errh) of
|
||||
(Just inh, Just outh, Just errh) -> do
|
||||
|
||||
out <- BS.hGetContents outh
|
||||
err <- BS.hGetContents errh
|
||||
|
||||
-- fork off threads to start consuming stdout & stderr
|
||||
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
|
||||
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
|
||||
|
||||
-- now write any input
|
||||
unless (BL.null input) $
|
||||
ignoreSigPipe $ BL.hPut inh input
|
||||
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
|
||||
ignoreSigPipe $ hClose inh
|
||||
|
||||
-- wait on the output
|
||||
waitOut
|
||||
waitErr
|
||||
|
||||
hClose outh
|
||||
hClose errh
|
||||
|
||||
-- wait on the process
|
||||
ex <- waitForProcess ph
|
||||
return (ex, BL.fromStrict out, BL.fromStrict err)
|
||||
|
||||
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
|
||||
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
|
||||
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
|
||||
where
|
||||
ignoreSigPipe :: IO () -> IO ()
|
||||
ignoreSigPipe = EX.handle $ \e -> case e of
|
||||
IOError { ioe_type = ResourceVanished
|
||||
, ioe_errno = Just ioe }
|
||||
| Errno ioe == ePIPE -> return ()
|
||||
_ -> throwIO e
|
||||
-- wrapper so we can get exceptions with the appropriate function name.
|
||||
withCreateProcess_
|
||||
:: String
|
||||
-> CreateProcess
|
||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||
-> IO a
|
||||
withCreateProcess_ fun c action =
|
||||
EX.bracketOnError (createProcess_ fun c) cleanupProcess
|
||||
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
|
||||
|
||||
-- | Fork a thread while doing something else, but kill it if there's an
|
||||
-- exception.
|
||||
--
|
||||
-- This is important in the cases above because we want to kill the thread
|
||||
-- that is holding the Handle lock, because when we clean up the process we
|
||||
-- try to close that handle, which could otherwise deadlock.
|
||||
--
|
||||
withForkWait :: IO () -> (IO () -> IO a) -> IO a
|
||||
withForkWait async' body = do
|
||||
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
|
||||
mask $ \restore -> do
|
||||
tid <- forkIO $ try (restore async') >>= putMVar waitVar
|
||||
let wait' = takeMVar waitVar >>= either throwIO return
|
||||
restore (body wait') `EX.onException` killThread tid
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: MonadIO m
|
||||
=> FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> m CapturedProcess
|
||||
executeOut path args chdir = do
|
||||
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
|
||||
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
|
||||
pure $ CapturedProcess exit out err
|
||||
|
||||
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, HasSettings env
|
||||
, MonadIO m
|
||||
, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> FilePath -- ^ log filename (opened in append mode)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
Dirs {..} <- getDirs
|
||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||
let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"
|
||||
cp <- createProcessWithMingwPath ((proc exe args)
|
||||
{ cwd = chdir
|
||||
, env = env
|
||||
, std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
})
|
||||
fmap (toProcessError exe args)
|
||||
$ liftIO
|
||||
$ withCreateProcess cp
|
||||
$ \_ mout merr ph ->
|
||||
case (mout, merr) of
|
||||
(Just cStdout, Just cStderr) -> do
|
||||
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
|
||||
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
|
||||
waitOut
|
||||
waitErr
|
||||
waitForProcess ph
|
||||
_ -> fail "Could not acquire out/err handle"
|
||||
|
||||
where
|
||||
tee :: FilePath -> Handle -> IO ()
|
||||
tee logFile handle' = go
|
||||
where
|
||||
go = do
|
||||
some <- BS.hGetSome handle' 512
|
||||
if BS.null some
|
||||
then pure ()
|
||||
else do
|
||||
void $ BS.appendFile logFile some
|
||||
-- subprocess stdout also goes to stderr for logging
|
||||
void $ BS.hPut stderr some
|
||||
go
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
exec exe args chdir env = do
|
||||
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError exe args exit_code
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
execShell :: MonadIO m
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execShell exe args chdir env = do
|
||||
let cmd = exe <> " " <> concatMap (' ':) args
|
||||
cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError cmd [] exit_code
|
||||
|
||||
|
||||
createProcessWithMingwPath :: MonadIO m
|
||||
=> CreateProcess
|
||||
-> m CreateProcess
|
||||
createProcessWithMingwPath cp = do
|
||||
msys2Dir <- liftIO ghcupMsys2Dir
|
||||
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
|
||||
let mingWPaths = [msys2Dir </> "usr" </> "bin"
|
||||
,msys2Dir </> "mingw64" </> "bin"]
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
envWithNewPath = Map.insert "Path" newPath envWithoutPath
|
||||
liftIO $ setEnv "Path" newPath
|
||||
pure $ cp { env = Just $ Map.toList envWithNewPath }
|
||||
|
||||
ghcupMsys2Dir :: IO FilePath
|
||||
ghcupMsys2Dir =
|
||||
lookupEnv "GHCUP_MSYS2" >>= \case
|
||||
Just fp -> pure fp
|
||||
Nothing -> do
|
||||
baseDir <- liftIO ghcupBaseDir
|
||||
pure (fromGHCupPath baseDir </> "msys64")
|
||||
|
||||
@ -30,7 +30,7 @@ Any instance of the IsString type is permitted.
|
||||
(For GHC versions 6, write "[$s||]" instead of "[s||]".)
|
||||
|
||||
-}
|
||||
module GHCup.Utils.String.QQ
|
||||
module GHCup.Prelude.String.QQ
|
||||
( s
|
||||
)
|
||||
where
|
||||
@ -16,7 +16,7 @@ Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.Version.QQ where
|
||||
module GHCup.Prelude.Version.QQ where
|
||||
|
||||
import Data.Data
|
||||
import Data.Text ( Text )
|
||||
@ -3,7 +3,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module GHCup.Utils.Windows where
|
||||
module GHCup.Prelude.Windows where
|
||||
|
||||
|
||||
import Control.Exception.Safe
|
||||
@ -46,3 +46,8 @@ enableAnsiSupport = handleIO (pure . Left . displayException) $ do
|
||||
>> pure (Right False)
|
||||
else pure (Right True)
|
||||
|
||||
|
||||
isWindows, isNotWindows :: Bool
|
||||
isWindows = True
|
||||
isNotWindows = not isWindows
|
||||
|
||||
278
lib/GHCup/Stack.hs
Normal file
278
lib/GHCup/Stack.hs
Normal file
@ -0,0 +1,278 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Stack
|
||||
Description : GHCup installation functions for Stack
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Stack where
|
||||
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
|
||||
import Codec.Archive ( ArchiveResult )
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Versions hiding ( patch )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import Safe hiding ( at )
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ Installation ]--
|
||||
--------------------
|
||||
|
||||
|
||||
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
|
||||
-- creates a default @stack -> stack-x.y.z.q@ symlink for
|
||||
-- the latest installed version.
|
||||
installStackBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Version
|
||||
-> InstallDir
|
||||
-> Bool -- ^ Force install
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
m
|
||||
()
|
||||
installStackBin ver installDir forceInstall = do
|
||||
dlinfo <- liftE $ getDownloadInfo Stack ver
|
||||
installStackBindist dlinfo ver installDir forceInstall
|
||||
|
||||
|
||||
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installStackBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> InstallDir
|
||||
-> Bool -- ^ Force install
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ArchiveResult
|
||||
, FileAlreadyExistsError
|
||||
]
|
||||
m
|
||||
()
|
||||
installStackBindist dlinfo ver installDir forceInstall = do
|
||||
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
|
||||
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
regularStackInstalled <- lift $ stackInstalled ver
|
||||
|
||||
if
|
||||
| not forceInstall
|
||||
, regularStackInstalled
|
||||
, GHCupInternal <- installDir -> do
|
||||
throwE $ AlreadyInstalled Stack ver
|
||||
|
||||
| forceInstall
|
||||
, regularStackInstalled
|
||||
, GHCupInternal <- installDir -> do
|
||||
lift $ logInfo "Removing the currently installed version of Stack first!"
|
||||
liftE $ rmStackVer ver
|
||||
|
||||
| otherwise -> pure ()
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
case installDir of
|
||||
IsolateDir isoDir -> do -- isolated install
|
||||
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
|
||||
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||
GHCupInternal -> do -- regular install
|
||||
liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall
|
||||
|
||||
|
||||
-- | Install an unpacked stack distribution.
|
||||
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
|
||||
=> GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||
-> InstallDirResolved
|
||||
-> Version
|
||||
-> Bool -- ^ Force install
|
||||
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
|
||||
installStackUnpacked path installDir ver forceInstall = do
|
||||
lift $ logInfo "Installing stack"
|
||||
let stackFile = "stack"
|
||||
liftIO $ createDirRecursive' (fromInstallDir installDir)
|
||||
let destFileName = stackFile
|
||||
<> (case installDir of
|
||||
IsolateDirResolved _ -> ""
|
||||
_ -> ("-" <>) . T.unpack . prettyVer $ ver
|
||||
)
|
||||
<> exeExt
|
||||
destPath = fromInstallDir installDir </> destFileName
|
||||
|
||||
copyFileE
|
||||
(fromGHCupPath path </> stackFile <> exeExt)
|
||||
destPath
|
||||
(not forceInstall)
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Set stack ]--
|
||||
-----------------
|
||||
|
||||
|
||||
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
|
||||
setStack :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setStack ver = do
|
||||
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
|
||||
|
||||
let stackbin = binDir </> "stack" <> exeExt
|
||||
|
||||
lift $ createLink targetFile stackbin
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
unsetStack :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m)
|
||||
=> m ()
|
||||
unsetStack = do
|
||||
Dirs {..} <- getDirs
|
||||
let stackbin = binDir </> "stack" <> exeExt
|
||||
hideError doesNotExistErrorType $ rmLink stackbin
|
||||
|
||||
|
||||
----------------
|
||||
--[ Rm stack ]--
|
||||
----------------
|
||||
|
||||
-- | Delete a stack version. Will try to fix the @stack@ symlink
|
||||
-- after removal (e.g. setting it to an older version).
|
||||
rmStackVer :: ( MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmStackVer ver = do
|
||||
whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
|
||||
|
||||
sSet <- lift stackSet
|
||||
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
|
||||
|
||||
when (Just ver == sSet) $ do
|
||||
sVers <- lift $ fmap rights getInstalledStacks
|
||||
case headMay . reverse . sort $ sVers of
|
||||
Just latestver -> setStack latestver
|
||||
Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)
|
||||
@ -26,8 +26,7 @@ module GHCup.Types
|
||||
)
|
||||
where
|
||||
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath )
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath )
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
|
||||
|
||||
import Control.DeepSeq ( NFData, rnf )
|
||||
import Data.Map.Strict ( Map )
|
||||
|
||||
@ -23,7 +23,7 @@ module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON.Utils
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Prelude.MegaParsec
|
||||
|
||||
import Control.Applicative ( (<|>) )
|
||||
import Data.Aeson hiding (Key)
|
||||
|
||||
@ -23,18 +23,18 @@ module GHCup.Utils
|
||||
( module GHCup.Utils.Dirs
|
||||
, module GHCup.Utils
|
||||
#if defined(IS_WINDOWS)
|
||||
, module GHCup.Utils.Windows
|
||||
, module GHCup.Prelude.Windows
|
||||
#else
|
||||
, module GHCup.Utils.Posix
|
||||
, module GHCup.Prelude.Posix
|
||||
#endif
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Utils.Windows
|
||||
import GHCup.Prelude.Windows
|
||||
#else
|
||||
import GHCup.Utils.Posix
|
||||
import GHCup.Prelude.Posix
|
||||
#endif
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
@ -42,11 +42,13 @@ import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Version
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
import GHCup.Prelude.MegaParsec
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Codec.Archive hiding ( Directory )
|
||||
import Control.Applicative
|
||||
@ -75,6 +77,7 @@ import Safe
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.Regex.Posix
|
||||
import Text.PrettyPrint.HughesPJClass (prettyShow)
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
@ -99,14 +102,14 @@ import GHC.IO (evaluate)
|
||||
-- >>> import System.Directory
|
||||
-- >>> import URI.ByteString
|
||||
-- >>> import qualified Data.Text as T
|
||||
-- >>> import GHCup.Utils.Prelude
|
||||
-- >>> import GHCup.Prelude
|
||||
-- >>> import GHCup.Download
|
||||
-- >>> import GHCup.Version
|
||||
-- >>> import GHCup.Errors
|
||||
-- >>> import GHCup.Types
|
||||
-- >>> import GHCup.Types.Optics
|
||||
-- >>> import Optics
|
||||
-- >>> import GHCup.Utils.Version.QQ
|
||||
-- >>> import GHCup.Prelude.Version.QQ
|
||||
-- >>> import qualified Data.Text.Encoding as E
|
||||
-- >>> import Control.Monad.Reader
|
||||
-- >>> import Haskus.Utils.Variant.Excepts
|
||||
@ -1019,6 +1022,28 @@ applyPatch patch ddir = do
|
||||
!? PatchFailed
|
||||
|
||||
|
||||
applyAnyPatch :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, HasSettings env
|
||||
, MonadUnliftIO m
|
||||
, MonadCatch m
|
||||
, MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadMask m
|
||||
, MonadIO m)
|
||||
=> Maybe (Either FilePath [URI])
|
||||
-> FilePath
|
||||
-> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
|
||||
applyAnyPatch Nothing _ = pure ()
|
||||
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
|
||||
applyAnyPatch (Just (Right uris)) workdir = do
|
||||
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
|
||||
forM_ uris $ \uri -> do
|
||||
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
|
||||
liftE $ applyPatch patch workdir
|
||||
|
||||
|
||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
||||
darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
|
||||
=> Platform
|
||||
@ -1134,97 +1159,6 @@ getVersionInfo v' tool =
|
||||
)
|
||||
|
||||
|
||||
-- | The file extension for executables.
|
||||
exeExt :: String
|
||||
exeExt
|
||||
| isWindows = ".exe"
|
||||
| otherwise = ""
|
||||
|
||||
-- | The file extension for executables.
|
||||
exeExt' :: ByteString
|
||||
exeExt'
|
||||
| isWindows = ".exe"
|
||||
| otherwise = ""
|
||||
|
||||
|
||||
|
||||
|
||||
-- | On unix, we can use symlinks, so we just get the
|
||||
-- symbolic link target.
|
||||
--
|
||||
-- On windows, we have to emulate symlinks via shims,
|
||||
-- see 'createLink'.
|
||||
getLinkTarget :: FilePath -> IO FilePath
|
||||
getLinkTarget fp
|
||||
| isWindows = do
|
||||
content <- readFile (dropExtension fp <.> "shim")
|
||||
[p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
|
||||
pure $ stripNewline $ dropPrefix "path = " p
|
||||
| otherwise = getSymbolicLinkTarget fp
|
||||
|
||||
|
||||
-- | Checks whether the path is a link.
|
||||
pathIsLink :: FilePath -> IO Bool
|
||||
pathIsLink fp
|
||||
| isWindows = doesPathExist (dropExtension fp <.> "shim")
|
||||
| otherwise = pathIsSymbolicLink fp
|
||||
|
||||
|
||||
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
|
||||
rmLink fp
|
||||
| isWindows = do
|
||||
hideError doesNotExistErrorType . recycleFile $ fp
|
||||
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
|
||||
| otherwise = hideError doesNotExistErrorType . recycleFile $ fp
|
||||
|
||||
|
||||
-- | Creates a symbolic link on unix and a fake symlink on windows for
|
||||
-- executables, which:
|
||||
-- 1. is a shim exe
|
||||
-- 2. has a corresponding .shim file in the same directory that
|
||||
-- contains the target
|
||||
--
|
||||
-- This overwrites previously existing files.
|
||||
--
|
||||
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
|
||||
createLink :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> FilePath -- ^ path to the target executable
|
||||
-> FilePath -- ^ path to be created
|
||||
-> m ()
|
||||
createLink link exe
|
||||
| isWindows = do
|
||||
dirs <- getDirs
|
||||
let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
|
||||
|
||||
let shim = dropExtension exe <.> "shim"
|
||||
-- For hardlinks, link needs to be absolute.
|
||||
-- If link is relative, it's relative to the target exe.
|
||||
-- Note that (</>) drops lhs when rhs is absolute.
|
||||
fullLink = takeDirectory exe </> link
|
||||
shimContents = "path = " <> fullLink
|
||||
|
||||
logDebug $ "rm -f " <> T.pack exe
|
||||
rmLink exe
|
||||
|
||||
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
|
||||
liftIO $ copyFile shimGen exe False
|
||||
liftIO $ writeFile shim shimContents
|
||||
| otherwise = do
|
||||
logDebug $ "rm -f " <> T.pack exe
|
||||
hideError doesNotExistErrorType $ recycleFile exe
|
||||
|
||||
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
|
||||
liftIO $ createFileLink link exe
|
||||
|
||||
|
||||
ensureGlobalTools :: ( MonadMask m
|
||||
, MonadThrow m
|
||||
, HasLog env
|
||||
@ -1316,3 +1250,28 @@ getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do
|
||||
pure (Just $ lines c)
|
||||
|
||||
|
||||
-- | Warn if the installed and set HLS is not compatible with the installed and
|
||||
-- set GHC version.
|
||||
warnAboutHlsCompatibility :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
)
|
||||
=> m ()
|
||||
warnAboutHlsCompatibility = do
|
||||
supportedGHC <- hlsGHCVersions
|
||||
currentGHC <- fmap _tvVersion <$> ghcSet Nothing
|
||||
currentHLS <- hlsSet
|
||||
|
||||
case (currentGHC, currentHLS) of
|
||||
(Just gv, Just hv) | gv `notElem` supportedGHC -> do
|
||||
logWarn $
|
||||
"GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
|
||||
"Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
|
||||
"Haskell IDE support may not work until this is fixed." <> "\n" <>
|
||||
"Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
|
||||
T.pack (prettyShow supportedGHC)
|
||||
|
||||
_ -> return ()
|
||||
|
||||
@ -1,4 +0,0 @@
|
||||
module GHCup.Utils where
|
||||
|
||||
getLinkTarget :: FilePath -> IO FilePath
|
||||
pathIsLink :: FilePath -> IO Bool
|
||||
@ -99,9 +99,6 @@ module GHCup.Utils.Dirs
|
||||
, setAccessTime
|
||||
, setModificationTime
|
||||
, isSymbolicLink
|
||||
|
||||
-- uhm
|
||||
, rmPathForcibly
|
||||
)
|
||||
where
|
||||
|
||||
@ -110,11 +107,15 @@ import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.MegaParsec
|
||||
import GHCup.Prelude.File.Search
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.Prelude.Logger.Internal (logWarn, logDebug)
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Prelude.Windows ( isWindows )
|
||||
#else
|
||||
import GHCup.Prelude.Posix ( isWindows )
|
||||
#endif
|
||||
|
||||
import Control.DeepSeq (NFData, rnf)
|
||||
import Control.Exception.Safe
|
||||
@ -147,6 +148,7 @@ import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Yaml.Aeson as Y
|
||||
import qualified Text.Megaparsec as MP
|
||||
import System.IO.Error (ioeGetErrorType)
|
||||
|
||||
|
||||
|
||||
@ -371,10 +373,15 @@ ghcupConfigFile :: (MonadIO m)
|
||||
=> Excepts '[JSONError] m UserSettings
|
||||
ghcupConfigFile = do
|
||||
filepath <- getConfigFilePath
|
||||
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
|
||||
contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
|
||||
case contents of
|
||||
Nothing -> pure defaultUserSettings
|
||||
Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'
|
||||
Just contents' -> liftE
|
||||
. veitherToExcepts @_ @'[JSONError]
|
||||
. either (VLeft . V) VRight
|
||||
. first (JSONDecodeError . displayException)
|
||||
. Y.decodeEither'
|
||||
$ contents'
|
||||
|
||||
|
||||
-------------------------
|
||||
@ -411,6 +418,12 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
|
||||
parseGHCupHLSDir (T.pack -> fp) =
|
||||
throwEither $ MP.parse version' "" fp
|
||||
|
||||
-- TODO: inlined from GHCup.Prelude
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
throwEither a = case a of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
-- | ~/.ghcup/hls by default, for new-style installs.
|
||||
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
|
||||
ghcupHLSBaseDir = do
|
||||
@ -459,7 +472,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
|
||||
(\fp ->
|
||||
handleIO (\e -> run
|
||||
$ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
|
||||
. rmPathForcibly
|
||||
. removePathForcibly
|
||||
$ fp))
|
||||
|
||||
|
||||
@ -522,13 +535,5 @@ removePathForcibly :: GHCupPath -> IO ()
|
||||
removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp
|
||||
|
||||
|
||||
rmPathForcibly :: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupPath
|
||||
-> m ()
|
||||
rmPathForcibly fp
|
||||
| isWindows = recover (liftIO $ removePathForcibly fp)
|
||||
| otherwise = liftIO $ removePathForcibly fp
|
||||
|
||||
|
||||
|
||||
@ -1,14 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module GHCup.Utils.File (
|
||||
recycleFile
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Reader (MonadReader)
|
||||
import GHCup.Types.Optics (HasDirs)
|
||||
|
||||
|
||||
recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
|
||||
|
||||
@ -1,5 +0,0 @@
|
||||
module GHCup.Utils.File.Common where
|
||||
|
||||
import Text.Regex.Posix
|
||||
|
||||
findFiles :: FilePath -> Regex -> IO [FilePath]
|
||||
@ -1,19 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Data.Text ( Text )
|
||||
import Optics
|
||||
|
||||
logWarn :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
|
||||
@ -1,8 +0,0 @@
|
||||
module GHCup.Utils.Prelude.Posix where
|
||||
|
||||
|
||||
isWindows, isNotWindows :: Bool
|
||||
isWindows = False
|
||||
isNotWindows = not isWindows
|
||||
|
||||
|
||||
@ -1,6 +0,0 @@
|
||||
module GHCup.Utils.Prelude.Windows where
|
||||
|
||||
isWindows, isNotWindows :: Bool
|
||||
isWindows = True
|
||||
isNotWindows = not isWindows
|
||||
|
||||
@ -16,12 +16,18 @@ import GHCup.Types
|
||||
import Paths_ghcup (version)
|
||||
|
||||
import Data.Version (Version(versionBranch))
|
||||
import Data.Versions hiding (version)
|
||||
import URI.ByteString
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Versions as V
|
||||
import Control.Exception.Safe (MonadThrow)
|
||||
import Data.Text (Text)
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Data.List (intersperse)
|
||||
import Control.Monad.Catch (throwM)
|
||||
import GHCup.Errors (ParseError(..))
|
||||
|
||||
-- | This reflects the API version of the YAML.
|
||||
--
|
||||
@ -31,22 +37,72 @@ ghcupURL :: URI
|
||||
ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|]
|
||||
|
||||
-- | The current ghcup version.
|
||||
ghcUpVer :: PVP
|
||||
ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version
|
||||
ghcUpVer :: V.PVP
|
||||
ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version
|
||||
|
||||
-- | ghcup version as numeric string.
|
||||
numericVer :: String
|
||||
numericVer = T.unpack . prettyPVP $ ghcUpVer
|
||||
numericVer = T.unpack . V.prettyPVP $ ghcUpVer
|
||||
|
||||
versionCmp :: Versioning -> VersionCmp -> Bool
|
||||
versionCmp :: V.Versioning -> VersionCmp -> Bool
|
||||
versionCmp ver1 (VR_gt ver2) = ver1 > ver2
|
||||
versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2
|
||||
versionCmp ver1 (VR_lt ver2) = ver1 < ver2
|
||||
versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
|
||||
versionCmp ver1 (VR_eq ver2) = ver1 == ver2
|
||||
|
||||
versionRange :: Versioning -> VersionRange -> Bool
|
||||
versionRange :: V.Versioning -> VersionRange -> Bool
|
||||
versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
|
||||
versionRange ver' (OrRange cmps range) =
|
||||
versionRange ver' (SimpleRange cmps) || versionRange ver' range
|
||||
|
||||
pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version
|
||||
pvpToVersion pvp_ rest =
|
||||
either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . V.version . (<> rest) . V.prettyPVP $ pvp_
|
||||
|
||||
-- | Convert a version to a PVP and unparsable rest.
|
||||
--
|
||||
-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
|
||||
versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text)
|
||||
versionToPVP (V.Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
|
||||
versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . V.pvp . V.prettyVer $ v
|
||||
where
|
||||
alternative :: MonadThrow m => V.Version -> m V.PVP
|
||||
alternative v' = case NE.takeWhile isDigit (V._vChunks v') of
|
||||
[] -> throwM $ ParseError "Couldn't convert Version to PVP"
|
||||
xs -> pure $ pvpFromList (unsafeDigit <$> xs)
|
||||
|
||||
rest :: V.Version -> Text
|
||||
rest (V.Version _ cs pr me) =
|
||||
let chunks = NE.dropWhile isDigit cs
|
||||
ver = intersperse (T.pack ".") . chunksAsT $ chunks
|
||||
me' = maybe [] (\m -> [T.pack "+",m]) me
|
||||
pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
|
||||
prefix = case (ver, pr', me') of
|
||||
(_:_, _, _) -> T.pack "."
|
||||
_ -> T.pack ""
|
||||
in prefix <> mconcat (ver <> pr' <> me')
|
||||
where
|
||||
chunksAsT :: Functor t => t V.VChunk -> t Text
|
||||
chunksAsT = fmap (foldMap f)
|
||||
where
|
||||
f :: V.VUnit -> Text
|
||||
f (V.Digits i) = T.pack $ show i
|
||||
f (V.Str s) = s
|
||||
|
||||
foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
|
||||
foldable d g f | null f = d
|
||||
| otherwise = g f
|
||||
|
||||
|
||||
|
||||
isDigit :: V.VChunk -> Bool
|
||||
isDigit (V.Digits _ :| []) = True
|
||||
isDigit _ = False
|
||||
|
||||
unsafeDigit :: V.VChunk -> Int
|
||||
unsafeDigit (V.Digits x :| []) = fromIntegral x
|
||||
unsafeDigit _ = error "unsafeDigit: wrong input"
|
||||
|
||||
pvpFromList :: [Int] -> V.PVP
|
||||
pvpFromList = V.PVP . NE.fromList . fmap fromIntegral
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module GHCup.Utils.FileSpec where
|
||||
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Prelude.File
|
||||
|
||||
import Data.List
|
||||
import System.Directory
|
||||
|
||||
Loading…
Reference in New Issue
Block a user