{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeApplications      #-}

-- TODO: handle SIGTERM, SIGUSR
module GHCup where


import qualified Codec.Archive.Tar             as Tar
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Fail             ( MonadFail )
import           Control.Monad.Reader
import           Control.Monad.Logger
import           Control.Monad.Cont
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Class      ( lift )
import           Control.Monad.IO.Class
import           Control.Exception.Safe
import           Data.ByteString                ( ByteString )
import           Data.Foldable                  ( asum )
import           Data.String.QQ
import           Data.Text                      ( Text )
import           Data.Versions
import           GHCup.Bash
import           GHCup.File
import           GHCup.Prelude
import           GHCup.Types
import           GHCup.Types.Optics
import           HPath
import           HPath.IO
import           Optics
import           Prelude                 hiding ( abs
                                                , readFile
                                                )
import           System.Info
import           System.IO.Error
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as E
import qualified Data.Text.ICU                 as ICU
import           Data.Maybe
import qualified Data.Map.Strict               as Map
import           Data.Word8
import           GHC.IO.Exception
import           GHC.IO.Handle
import           Haskus.Utils.Variant.Excepts
import           Haskus.Utils.Variant.VEither
import           Network.Http.Client     hiding ( URL )
import           System.IO.Streams              ( InputStream
                                                , OutputStream
                                                , stdout
                                                )
import qualified System.IO.Streams             as Streams
import           System.Posix.FilePath          ( takeExtension
                                                , takeFileName
                                                , splitExtension
                                                )
import qualified System.Posix.FilePath         as FP
import           System.Posix.Files.ByteString  ( readSymbolicLink )
import           System.Posix.Env.ByteString    ( getEnvDefault )
import           System.Posix.Temp.ByteString
import           System.Posix.RawFilePath.Directory.Errors
                                                ( hideError )
import "unix"    System.Posix.IO.ByteString
                                         hiding ( fdWrite )
import           System.Posix.FD               as FD
import           System.Posix.Foreign           ( oTrunc )
import qualified Data.ByteString               as B
import           OpenSSL                        ( withOpenSSL )
import qualified Data.ByteString.Char8         as C
import           Data.Functor                   ( ($>) )
import           System.Posix.Types
import "unix-bytestring" System.Posix.IO.ByteString
                                                ( fdWrite )

import qualified Codec.Compression.GZip        as GZip
import qualified Codec.Compression.Lzma        as Lzma
import qualified Codec.Compression.BZip        as BZip

import qualified Data.ByteString.UTF8          as UTF8
import qualified System.Posix.Process.ByteString
                                               as SPPB
import           System.Posix.Directory.ByteString
                                                ( changeWorkingDirectory )
import           URI.ByteString
import           URI.ByteString.QQ



data Settings = Settings
  { cache :: Bool
  }
  deriving Show




    ---------------------------
    --[ Excepts Error types ]--
    ---------------------------


data PlatformResultError = NoCompatiblePlatform
  deriving Show

data NoDownload = NoDownload
  deriving Show

data NoCompatibleArch = NoCompatibleArch String
  deriving Show

data DistroNotFound = DistroNotFound
  deriving Show

data ArchiveError = UnknownArchive ByteString
  deriving Show

data URLException = UnsupportedURL
  deriving Show

data FileError = CopyError String
  deriving Show

data TagNotFound = TagNotFound Tag Tool
  deriving Show

data AlreadyInstalled = AlreadyInstalled ToolRequest
  deriving Show

data NotInstalled = NotInstalled ToolRequest
  deriving Show



    --------------------------------
    --[ AvailableDownloads stuff ]--
    --------------------------------


-- TODO: version quasiquoter
availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
  [ ( GHC
    , Map.fromList
      [ ( [ver|8.6.5|]
        , VersionInfo [Latest] $ Map.fromList
          [ ( A_64
            , Map.fromList
              [ ( Linux UnknownLinux
                , Map.fromList
                  [ ( Nothing
                    , DownloadInfo
                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
                    )
                  ]
                )
              , ( Linux Ubuntu
                , Map.fromList
                  [ ( Nothing
                    , DownloadInfo
                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
                    )
                  ]
                )
              , ( Linux Debian
                , Map.fromList
                  [ ( Nothing
                    , DownloadInfo
                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
                    )
                  , ( Just $ [vers|8|]
                    , DownloadInfo
                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
                    )
                  ]
                )
              ]
            )
          ]
        )
      ]
    )
  , ( Cabal
    , Map.fromList
      [ ( [ver|3.0.0.0|]
        , VersionInfo [Recommended, Latest] $ Map.fromList
          [ ( A_64
            , Map.fromList
              [ ( Linux UnknownLinux
                , Map.fromList
                  [ ( Nothing
                    , DownloadInfo
                      [uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
                      Nothing
                    )
                  ]
                )
              ]
            )
          ]
        )
      ]
    )
  ]



-- | Get the tool versions that have this tag.
getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
  ( ix tool
  % to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
  % to Map.keys
  % folded
  )
  av

getLatest :: AvailableDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest

getRecommended :: AvailableDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended



    ----------------------
    --[ Download stuff ]--
    ----------------------


getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
                => ToolRequest
                -> Maybe PlatformRequest
                -> URLSource
                -> Excepts
                     '[ PlatformResultError
                      , NoDownload
                      , NoCompatibleArch
                      , DistroNotFound
                      ]
                     m
                     DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
  lift $ $(logDebug) ([s|Receiving download info from: |] <> showT urlSource)
  -- lift $ monadLoggerLog undefined undefined undefined ""
  (PlatformRequest arch plat ver) <- case mpfReq of
    Just x  -> pure x
    Nothing -> do
      (PlatformResult rp rv) <- liftE getPlatform
      ar                     <- lE getArchitecture
      pure $ PlatformRequest ar rp rv

  dls <- case urlSource of
    -- TODO
    GHCupURL      -> fail "Not implemented"
    OwnSource url -> fail "Not implemented"
    OwnSpec   dls -> pure dls

  lE $ getDownloadInfo' t v arch plat ver dls


getDownloadInfo' :: Tool
                 -> Version
                -- ^ tool version
                 -> Architecture
                -- ^ user arch
                 -> Platform
                -- ^ user platform
                 -> Maybe Versioning
                -- ^ optional version of the platform
                 -> AvailableDownloads
                 -> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
  (Left NoDownload)
  Right
  (with_distro <|> without_distro_ver <|> without_distro)

 where
  with_distro        = distro_preview id id
  without_distro_ver = distro_preview id (const Nothing)
  without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)

  distro_preview f g =
    preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls


-- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we:
--   1. try to guess the filename from the url path
--   2. otherwise create a random file
--
-- The file must not exist.
download :: Bool             -- ^ https?
         -> ByteString       -- ^ host (e.g. "www.example.com")
         -> ByteString       -- ^ path (e.g. "/my/file")
         -> Maybe Int        -- ^ 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))

-- | Same as 'download', except uses URL type. As such, this might
-- throw an exception if the url type or host protocol is not supported.
--
-- Only Absolute HTTP/HTTPS is supported.
download' :: (MonadLogger m, MonadIO m)
          => DownloadInfo
          -> Path Abs          -- ^ destination dir
          -> Maybe (Path Rel)  -- ^ optional filename
          -> Excepts '[URLException] m (Path Abs)
download' dli dest mfn
  | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
  | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
  | otherwise = throwE UnsupportedURL

 where
  dl https = do
    lift $ $(logInfo)
      ([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli)))
    host <-
      preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
        ?? UnsupportedURL
    let path = view (dlUri % pathL') dli
    let port = preview
          (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
          dli
    liftIO $ download https host path port dest mfn

-- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout.
downloadFd :: Bool            -- ^ https?
           -> ByteString      -- ^ host (e.g. "www.example.com")
           -> ByteString      -- ^ path (e.g. "/my/file")
           -> Maybe Int       -- ^ optional port (e.g. 3000)
           -> Fd              -- ^ function creating an Fd to write the body into
           -> IO ()
downloadFd https host path port fd =
  void $ downloadInternal https host path port (Left fd)


downloadInternal :: Bool
                 -> ByteString
                 -> ByteString
                 -> Maybe Int
                 -> Either Fd (Path Abs, Maybe (Path Rel))
                 -> IO (Maybe (Path Abs))
downloadInternal https host path port dest = do
  c <- case https of
    True -> do
      ctx <- baselineContextSSL
      openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
    False -> openConnection host (fromIntegral $ fromMaybe 80 port)

  let q = buildRequest1 $ http GET ([s|/|] <> path)

  sendRequest c q emptyBody

  (fd, mfp) <- case dest of
    Right (dest, mfn) -> getFile dest mfn <&> (<&> Just)
    Left  fd          -> pure (fd, Nothing)

  -- wrapper so we can close Fds we created
  let receiveResponse' c b = case dest of
        Right _ -> (flip finally) (closeFd fd) $ receiveResponse c b
        Left  _ -> receiveResponse c b

  receiveResponse'
    c
    (\p i -> do
      outStream <- Streams.makeOutputStream
        (\case
          Just bs -> void $ fdWrite fd bs
          Nothing -> pure ()
        )
      Streams.connect i outStream
    )

  closeConnection c

  pure mfp

 where
  -- Manage to find a file we can write the body into.
  getFile :: Path Abs -> Maybe (Path Rel) -> IO (Fd, Path Abs)
  getFile dest mfn = do
    -- destination dir must exist
    hideError AlreadyExists $ createDirRecursive newDirPerms dest
    case mfn of
      -- if a filename was provided, try that
      Just x ->
        let fp = dest </> x
        in  fmap (, fp) $ createRegularFileFd newFilePerms fp
      Nothing -> do
        -- ...otherwise try to infer the filename from the URL path
        fn' <- urlBaseName path
        let fp = dest </> fn'
        fmap (, fp) $ createRegularFileFd newFilePerms fp



    --------------------------
    --[ Platform detection ]--
    --------------------------


getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
  "x86_64" -> Right A_64
  "i386"   -> Right A_32
  what     -> Left (NoCompatibleArch what)



getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
            => Excepts
                 '[PlatformResultError , DistroNotFound]
                 m
                 PlatformResult
getPlatform = do
  pfr <- case os of
    "linux" -> do
      (distro, ver) <- liftE getLinuxDistro
      pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
    -- TODO: these are not verified
    "darwin" ->
      pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
    "freebsd" -> do
      ver <- getFreeBSDVersion
      pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
    what -> throwE NoCompatiblePlatform
  lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr)
  pure pfr
  where getFreeBSDVersion = pure Nothing


getLinuxDistro :: (MonadCatch m, MonadIO m)
               => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
  -- TODO: don't do alternative on IO, because it hides bugs
  (name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
    [ try_os_release
    , try_lsb_release_cmd
    , try_lsb_release
    , try_redhat_release
    , try_debian_version
    ]
  let parsedVer = ver >>= either (const Nothing) Just . versioning
      distro    = if
        | hasWord name ["debian"]  -> Debian
        | hasWord name ["ubuntu"]  -> Ubuntu
        | hasWord name ["linuxmint", "Linux Mint"] -> Mint
        | hasWord name ["fedora"]  -> Fedora
        | hasWord name ["centos"]  -> CentOS
        | hasWord name ["Red Hat"] -> RedHat
        | hasWord name ["alpine"]  -> Alpine
        | hasWord name ["exherbo"] -> Exherbo
        | hasWord name ["gentoo"]  -> Gentoo
        | otherwise                -> UnknownLinux
  pure (distro, parsedVer)
 where
  hasWord t matches = foldr
    (\x y ->
      ( isJust
        . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
        $ t
        )
        || y
    )
    False
    (T.pack <$> matches)

  os_release :: Path Abs
  os_release = [abs|/etc/os-release|]
  lsb_release :: Path Abs
  lsb_release = [abs|/etc/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
  debian_version = [abs|/etc/debian_version|]

  try_os_release :: IO (Text, Maybe Text)
  try_os_release = do
    (Just name) <- getAssignmentValueFor os_release "NAME"
    ver         <- getAssignmentValueFor os_release "VERSION_ID"
    pure (T.pack name, fmap T.pack ver)

  try_lsb_release_cmd :: IO (Text, Maybe Text)
  try_lsb_release_cmd = do
    (Just _) <- findExecutable lsb_release_cmd
    name     <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
    ver      <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
    pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)

  try_lsb_release :: IO (Text, Maybe Text)
  try_lsb_release = do
    (Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
    ver         <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
    pure (T.pack name, fmap T.pack ver)

  try_redhat_release :: IO (Text, Maybe Text)
  try_redhat_release = do
    t <- fmap lBS2sT $ readFile redhat_release
    let nameRe n =
          join
            . fmap (ICU.group 0)
            . ICU.find
                (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
            $ t
        verRe =
          join
            . fmap (ICU.group 0)
            . ICU.find
                (ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
            $ t
    (Just name) <- pure
      (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
    pure (name, verRe)

  try_debian_version :: IO (Text, Maybe Text)
  try_debian_version = do
    ver <- readFile debian_version
    pure (T.pack "debian", Just $ lBS2sT ver)


-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined



    -------------------------
    --[ Tool installation ]--
    -------------------------

-- TODO: custom logger intepreter and pretty printing

-- | Install a tool, such as GHC or cabal.
--
-- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal.
installTool :: ( MonadThrow m
               , MonadReader Settings m
               , MonadLogger m
               , MonadCatch m
               , MonadIO m
               )
            => ToolRequest
            -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
            -> URLSource
            -> Excepts
                 '[ AlreadyInstalled
                  , FileError
                  , ArchiveError
                  , ProcessError
                  , URLException
                  , PlatformResultError
                  , NoDownload
                  , NoCompatibleArch
                  , DistroNotFound
                  ]
                 m
                 ()
installTool treq mpfReq urlSource = do
  lift $ $(logDebug) ([s|Requested to install: |] <> showT treq)
  alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
  when alreadyInstalled $ (throwE $ AlreadyInstalled treq)

  Settings {..} <- lift ask

  -- download (or use cached version)
  dlinfo        <- liftE $ getDownloadInfo treq mpfReq urlSource
  dl            <- case cache of
    True -> do
      cachedir <- liftIO $ ghcupCacheDir
      fn       <- urlBaseName $ view (dlUri % pathL') dlinfo
      let cachfile = cachedir </> fn
      fileExists <- liftIO $ doesFileExist cachfile
      if
        | fileExists -> pure $ cachfile
        | otherwise  -> liftE $ download' dlinfo cachedir Nothing
    False -> do
      tmp <- liftIO mkGhcupTmpDir
      liftE $ download' dlinfo tmp Nothing

  -- unpack
  unpacked <- liftE $ unpackToTmpDir dl

  -- prepare paths
  ghcdir   <- liftIO $ ghcupGHCDir (view toolVersion $ treq)
  bindir   <- liftIO ghcupBinDir

  -- the subdir of the archive where we do the work
  let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)

  -- TODO: test if tool is already installed
  case treq of
    (ToolRequest GHC   ver) -> liftE $ installGHC archiveSubdir ghcdir
    (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
  pure ()


toolAlreadyInstalled :: ToolRequest -> IO Bool
toolAlreadyInstalled ToolRequest {..} = case _tool of
  GHC   -> ghcInstalled _toolVersion
  Cabal -> cabalInstalled _toolVersion



-- | Install an unpacked GHC distribution.
installGHC :: (MonadLogger m, MonadIO m)
           => Path Abs      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
           -> Path Abs      -- ^ Path to install to
           -> Excepts '[ProcessError] m ()
installGHC path inst = do
  lift $ $(logInfo) ([s|Installing GHC|])
  lEM $ liftIO $ exec [s|./configure|]
                      [[s|--prefix=|] <> toFilePath inst]
                      False
                      (Just path)
  lEM $ liftIO $ exec [s|make|] [[s|install|]] True (Just path)
  pure ()


-- | Install an unpacked cabal distribution.
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Path Abs      -- ^ Path to the unpacked cabal bindist (where the executable resides)
             -> Path Abs      -- ^ Path to install to
             -> Excepts '[FileError] m ()
installCabal path inst = do
  lift $ $(logInfo) ([s|Installing cabal|])
  let cabalFile = [rel|cabal|] :: Path Rel
  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
    (path </> cabalFile)
    (inst </> cabalFile)
    Overwrite


-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
--   * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
--   * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
--   * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
       => Version
       -> SetGHC
       -> Excepts '[NotInstalled] m ()
setGHC ver sghc = do
  let verBS = E.encodeUtf8 $ prettyVer ver -- as ByteString
  ghcdir   <- liftIO $ ghcupGHCDir ver

  -- symlink destination
  destdir  <- liftIO $ ghcupBinDir

  -- for ghc tools (ghc, ghci, haddock, ...)
  verfiles <- ghcToolFiles ghcdir
  forM verfiles $ \file -> do
    liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
    targetFile <- case sghc of
      SetGHCOnly  -> pure file
      SetGHCMajor -> do
        major <- E.encodeUtf8 <$> getGHCMajor ver
        parseRel (toFilePath file <> B.singleton _hyphen <> major)
      SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
    liftIO $ createSymlink
      (destdir </> targetFile)
      ([s|../ghc/|] <> verBS <> [s|/bin/|] <> toFilePath file)

  -- create symlink for share dir
  liftIO $ symlinkShareDir ghcdir destdir verBS

  pure ()

 where
    -- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/* while ignoring *-<ver> symlinks
  ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
               => Path Abs
               -> Excepts '[NotInstalled] m [Path Rel]
  ghcToolFiles ghcdir = do
    -- fail if ghc is not installed
    exists <- liftIO $ doesDirectoryExist ghcdir
    whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
          (throwE (NotInstalled $ ToolRequest GHC ver))

    files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
    -- figure out the <ver> suffix, because this might not be `Version` for
    -- alpha/rc releases, but x.y.a.somedate.
    (Just symver) <-
      (B.stripPrefix [s|ghc-|] . takeFileName)
        <$> (liftIO $ readSymbolicLink $ toFilePath
              (ghcdir </> ([rel|bin/ghc|] :: Path Rel))
            )
    when (B.null symver)
         (throwIO $ userError $ "Fatal: ghc symlink target is broken")
    pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files

  symlinkShareDir :: Path Abs -> Path Abs -> ByteString -> IO ()
  symlinkShareDir ghcdir destdir verBS = case sghc of
    SetGHCOnly -> do
      let sharedir     = [rel|share|] :: Path Rel
      let fullsharedir = ghcdir </> sharedir
      whenM (doesDirectoryExist fullsharedir) $ do
        liftIO $ hideError doesNotExistErrorType $ deleteFile
          (destdir </> sharedir)
        createSymlink
          (destdir </> sharedir)
          ([s|../ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
    _ -> pure ()


    -----------------
    --[ Utilities ]--
    -----------------


ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
  home <- liftIO getHomeDirectory
  pure (home </> ([rel|.ghcup|] :: Path Rel))

ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))

ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
  ghcbasedir <- ghcupGHCBaseDir
  verdir     <- parseRel (E.encodeUtf8 $ prettyVer ver)
  pure (ghcbasedir </> verdir)

ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
  ghcdir <- ghcupGHCDir ver
  doesDirectoryExist ghcdir

ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))

ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))

cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
  cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
  mc       <- executeOut cabalbin [[s|--numeric-version|]] Nothing
  let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
  pure (reportedVer == (E.encodeUtf8 $ prettyVer ver))


-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m Text
getGHCMajor ver = do
  semv <- case semver $ prettyVer ver of
    Right v -> pure v
    Left  e -> throwM e
  pure $ T.pack (show (_svMajor semv)) <> T.pack "." <> T.pack
    (show (_svMinor semv))


urlBaseName :: MonadThrow m
            => ByteString  -- ^ the url path (without scheme and host)
            -> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False



-- | Unpack an archive to a temporary directory and return that path.
unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
               => Path Abs       -- ^ archive path
               -> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do
  lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av))
  fn     <- toFilePath <$> basename av
  tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
  let untar bs = do
        Tar.unpack tmp . Tar.read $ bs
        parseAbs tmp

  -- extract, depending on file extension
  if
    | [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
      (untar . GZip.decompress =<< readFile av)
    | [s|.tar.xz|] `B.isSuffixOf` fn -> do
      filecontents <- liftIO $ readFile av
      let decompressed = Lzma.decompress filecontents
      liftIO $ untar decompressed
    | [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
      (untar . BZip.decompress =<< readFile av)
    | [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
    | otherwise -> throwE $ UnknownArchive fn