From 8e533e2465665282d60606010f3f4d084d6adc84 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 24 Jan 2020 23:43:11 +0100 Subject: [PATCH] Blah --- TODO.md | 1 + cabal.project | 7 +++++ ghcup.cabal | 2 ++ lib/GHCup.hs | 25 ++++++++-------- lib/GHCup/File.hs | 23 ++++----------- lib/GHCup/Types.hs | 9 ------ update-index-state.sh | 66 +++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 94 insertions(+), 39 deletions(-) create mode 100755 update-index-state.sh diff --git a/TODO.md b/TODO.md index efad741..8ee11e4 100644 --- a/TODO.md +++ b/TODO.md @@ -6,6 +6,7 @@ * mirror support * checksums * check for new version on start +* tarball tags as well as version tags? * --copy-compiler-tools * installing multiple versions in parallel? diff --git a/cabal.project b/cabal.project index 43ff2ca..151a985 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,7 @@ packages: ./ghcup.cabal +with-compiler: ghc-8.6.5 + optimization: 2 package streamly @@ -7,3 +9,8 @@ package streamly package ghcup ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 + +source-repository-package + type: git + location: https://github.com/composewell/streamly + tag: b8178cd08f7fc8180e4de83bde4b239cb0cfb31c diff --git a/ghcup.cabal b/ghcup.cabal index 4fea505..e764713 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -40,6 +40,7 @@ common parsec { build-depends: parsec >= 3.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common streamly { build-depends: streamly >= 0.7 } common strict-base { build-depends: strict-base >= 0.4 } +common tar-bytestring { build-depends: tar-bytestring >= 0.6.1 } common template-haskell { build-depends: template-haskell >= 2.7 } common text { build-depends: text >= 1.2 } common text-icu { build-depends: text-icu >= 0.7 } @@ -88,6 +89,7 @@ library , safe-exceptions , streamly , strict-base + , tar-bytestring , template-haskell , text , text-icu diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 7fe0217..1344f2c 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -191,6 +191,7 @@ getLinuxDistro = do | hasWord name ["exherbo"] -> Exherbo | hasWord name ["gentoo"] -> Gentoo | otherwise -> UnknownLinux + recreateSymlink undefined undefined Overwrite pure (distro, parsedVer) where hasWord t matches = foldr @@ -208,8 +209,8 @@ getLinuxDistro = do os_release = [abs|/etc/os-release|] lsb_release :: Path Abs lsb_release = [abs|/etc/lsb-release|] - lsb_release_cmd :: Path Fn - lsb_release_cmd = [fn|lsb-release|] + lsb_release_cmd :: Path Rel + lsb_release_cmd = [rel|lsb-release|] redhat_release :: Path Abs redhat_release = [abs|/etc/redhat-release|] debian_version :: Path Abs @@ -269,12 +270,12 @@ getLinuxDistro = do -- 2. otherwise create a random file -- -- The file must not exist. -download :: Bool -- ^ https? - -> String -- ^ host (e.g. "www.example.com") - -> String -- ^ path (e.g. "/my/file") - -> Maybe Integer -- ^ optional port (e.g. 3000) - -> Path Abs -- ^ destination directory to download into - -> Maybe (Path Fn) -- ^ optionally provided filename +download :: Bool -- ^ https? + -> String -- ^ host (e.g. "www.example.com") + -> String -- ^ path (e.g. "/my/file") + -> Maybe Integer -- ^ optional port (e.g. 3000) + -> Path Abs -- ^ destination directory to download into + -> Maybe (Path Rel) -- ^ optionally provided filename -> IO (Path Abs) download https host path port dest mfn = do fromJust <$> downloadInternal https host path port (Right (dest, mfn)) @@ -283,7 +284,7 @@ download https host path port dest mfn = do -- throw an exception if the url type or host protocol is not supported. -- -- Only Absolute HTTP/HTTPS is supported. -download' :: URL -> Path Abs -> Maybe (Path Fn) -> IO (Path Abs) +download' :: URL -> Path Abs -> Maybe (Path Rel) -> IO (Path Abs) download' url dest mfn = case url of URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] } -> download https host path port dest mfn @@ -306,7 +307,7 @@ downloadInternal :: Bool -> String -> String -> Maybe Integer - -> Either Fd (Path Abs, Maybe (Path Fn)) + -> Either Fd (Path Abs, Maybe (Path Rel)) -> IO (Maybe (Path Abs)) downloadInternal https host path port dest = do c <- case https of @@ -345,7 +346,7 @@ downloadInternal https host path port dest = do where -- Manage to find a file we can write the body into. - getFile :: Path Abs -> Maybe (Path Fn) -> IO (Fd, Path Abs) + getFile :: Path Abs -> Maybe (Path Rel) -> IO (Fd, Path Abs) getFile dest mfn = do -- destination dir must exist hideError AlreadyExists $ createDirRecursive newDirPerms dest @@ -358,7 +359,7 @@ downloadInternal https host path port dest = do -- ...otherwise try to infer the filename from the URL path case (snd . T.breakOnEnd (fS "/") . T.pack) <$> decString False path of Just x -> do - fn' <- parseFn (C.pack $ T.unpack x) + fn' <- parseRel (C.pack $ T.unpack x) let fp = dest fn' fmap (, fp) $ createRegularFileFd newFilePerms fp Nothing -> do diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 1e2adf5..4e1fd0e 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -49,24 +49,11 @@ data CapturedProcess = CapturedProcess { makeLenses ''CapturedProcess --- |Checks whether a file is executable. Follows symlinks. --- --- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). --- --- Throws: --- --- - `NoSuchThing` if the file does not exist --- --- Note: calls `access` -isExecutable :: Path b -> IO Bool -isExecutable p = fileAccess (toFilePath p) False False True - - readFd :: Fd -> IO L.ByteString readFd fd = do handle' <- fdToHandle fd let stream = - (S.unfold (SU.finally hClose FH.readChunks) handle') + (S.unfold (SU.finallyIO hClose FH.readChunks) handle') >>= arrayToByteString toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream) @@ -89,7 +76,7 @@ readFileLines p = do -- -- This shouldn't throw IO exceptions, unless getting the environment variable -- PATH does. -findExecutable :: RelC r => Path r -> IO (Maybe (Path Abs)) +findExecutable :: Path Rel -> IO (Maybe (Path Abs)) findExecutable ex = do sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath -- We don't want exceptions to mess up our result. If we can't @@ -102,10 +89,10 @@ findExecutable ex = do -- | Execute the given command and collect the stdout, stderr and the exit code. -- The command is run in a subprocess. -executeOut :: Path Fn -- ^ command as filename, e.g. 'ls' - -> [ByteString] -- ^ arguments to the command +executeOut :: Path Rel -- ^ command as filename, e.g. 'ls' + -> [ByteString] -- ^ arguments to the command -> IO (Maybe CapturedProcess) -executeOut path args = withFnPath path +executeOut path args = withRelPath path $ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index a7432b5..247c029 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -6,16 +6,7 @@ import Data.Map.Strict ( Map ) import Network.URL import qualified GHC.Generics as GHC import Data.Versions -import HPath -import System.Posix.Types -data DownloadDestination = DPath { - dDestDir :: Path Abs - , dFileName :: Maybe (Path Fn) - } | - Fd { - dFd :: Fd - } data Tool = GHC | Cabal diff --git a/update-index-state.sh b/update-index-state.sh new file mode 100755 index 0000000..356f6d5 --- /dev/null +++ b/update-index-state.sh @@ -0,0 +1,66 @@ +#!/usr/bin/env bash + +set -eu + +status_message() { + printf "\\033[0;32m%s\\033[0m\\n" "$1" +} + +error_message() { + printf "\\033[0;31m%s\\033[0m\\n" "$1" +} + +SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )" +CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache" + +if [ ! -f "${CACHE_LOCATION}" ] ; then + error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?" + exit 1 +fi + +if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then + error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update." + exit 3 +fi + +cabal v2-update + +arch=$(getconf LONG_BIT) + +case "${arch}" in +32) + byte_size=4 + magic_word="CABA1002" + ;; +64) + byte_size=8 + magic_word="00000000CABA1002" + ;; +*) + error_message "Unknown architecture (long bit): ${arch}" + exit 2 + ;; +esac + +# This is the logic to parse the binary format of 01-index.cache. +# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch. +# Better than copying the cabal-install source code. +if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then + error_message "Magic word does not match!" + exit 4 +fi +cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc) + +# If we got junk from the binary file, this should fail. +cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ") + + +status_message "Updating index state in ${SCRIPTPATH}/cabal.project" + +if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then + awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp" + mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project" +else + printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project" +fi +