Blah

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?

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

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

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

lib/GHCup/File.hs

@@ -49,24 +49,11 @@ data CapturedProcess = CapturedProcess {
 makeLenses ''CapturedProcess
 
 
---
---
---
---
-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
 
 

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

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
+