383 lines
13 KiB
Haskell
383 lines
13 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
-- TODO: handle SIGTERM, SIGUSR
|
|
module GHCup where
|
|
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.IO.Class
|
|
import Control.Exception.Safe
|
|
import Data.Foldable ( asum )
|
|
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 Network.URL
|
|
import Optics
|
|
import Prelude hiding ( abs
|
|
, readFile
|
|
)
|
|
import System.Info
|
|
import System.IO.Error
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.ICU as ICU
|
|
import Data.Maybe
|
|
import qualified Data.Map.Strict as Map
|
|
import GHC.IO.Exception
|
|
import GHC.IO.Handle
|
|
import Network.Http.Client hiding ( URL )
|
|
import System.IO.Streams ( InputStream
|
|
, OutputStream
|
|
, stdout
|
|
)
|
|
import qualified System.IO.Streams as Streams
|
|
import System.Posix.Temp.ByteString
|
|
import "unix" System.Posix.IO.ByteString
|
|
hiding ( fdWrite )
|
|
import System.Posix.FD as FD
|
|
import System.Posix.Directory.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 )
|
|
|
|
|
|
|
|
availableDownloads :: AvailableDownloads
|
|
availableDownloads = Map.fromList
|
|
[ ( GHC
|
|
, Map.fromList
|
|
[ ( (\(Right x) -> x) $ version (fS "8.6.5")
|
|
, Map.fromList
|
|
[ ( A_64
|
|
, Map.fromList
|
|
[ ( Linux UnknownLinux
|
|
, Map.fromList
|
|
[ ( Nothing
|
|
, mkGHCUrl
|
|
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
|
|
)
|
|
]
|
|
)
|
|
, ( Linux Debian
|
|
, Map.fromList
|
|
[ ( Nothing
|
|
, mkGHCUrl
|
|
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz"
|
|
)
|
|
, ( Just $ (\(Right x) -> x) $ versioning (fS "8")
|
|
, mkGHCUrl
|
|
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz"
|
|
)
|
|
]
|
|
)
|
|
]
|
|
)
|
|
]
|
|
)
|
|
]
|
|
)
|
|
]
|
|
where
|
|
mkGHCUrl path = URL
|
|
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
|
|
, url_path = path
|
|
, url_params = []
|
|
}
|
|
|
|
|
|
getDownloadURL :: ToolRequest
|
|
-> Maybe PlatformRequest
|
|
-> URLSource
|
|
-> IO (Maybe URL) -- TODO: better error handling
|
|
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
|
|
(PlatformRequest arch plat ver) <- case mpfReq of
|
|
Just x -> pure x
|
|
Nothing -> do
|
|
(PlatformResult rp rv) <- getPlatform
|
|
let ar = (\(Right x) -> x) getArchitecture
|
|
pure $ PlatformRequest ar rp rv
|
|
|
|
dls <- case urlSource of
|
|
GHCupURL -> fail "Not implemented"
|
|
OwnSource url -> fail "Not implemented"
|
|
OwnSpec dls -> pure dls
|
|
|
|
pure $ getDownloadURL' t v arch plat ver dls
|
|
|
|
|
|
getDownloadURL' :: Tool
|
|
-> Version
|
|
-- ^ tool version
|
|
-> Architecture
|
|
-- ^ user arch
|
|
-> Platform
|
|
-- ^ user platform
|
|
-> Maybe Versioning
|
|
-- ^ optional version of the platform
|
|
-> AvailableDownloads
|
|
-> Maybe URL
|
|
getDownloadURL' t v a p mv dls =
|
|
with_distro <|> without_distro_ver <|> without_distro
|
|
|
|
where
|
|
with_distro = distro_preview id id
|
|
without_distro = distro_preview (set _Linux UnknownLinux) id
|
|
without_distro_ver = distro_preview id (const Nothing)
|
|
|
|
distro_preview f g =
|
|
preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
|
|
atJust x = at x % _Just
|
|
|
|
|
|
getArchitecture :: Either String Architecture
|
|
getArchitecture = case arch of
|
|
"x86_64" -> pure A_64
|
|
"i386" -> pure A_32
|
|
what -> Left ("Could not find compatible architecture. Was: " <> what)
|
|
|
|
|
|
|
|
getPlatform :: IO PlatformResult
|
|
getPlatform = case os of
|
|
"linux" -> do
|
|
(distro, ver) <- 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 -> fail ("Could not find compatible platform. Was: " <> what)
|
|
where getFreeBSDVersion = pure Nothing
|
|
|
|
|
|
getLinuxDistro :: IO (LinuxDistro, Maybe Versioning)
|
|
getLinuxDistro = do
|
|
(name, ver) <- 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
|
|
recreateSymlink undefined undefined Overwrite
|
|
pure (distro, parsedVer)
|
|
where
|
|
hasWord t matches = foldr
|
|
(\x y ->
|
|
( isJust
|
|
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\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
|
|
(Just name) <- (fmap . fmap) _stdOut
|
|
$ executeOut lsb_release_cmd [fS "-si"]
|
|
ver <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [fS "-sr"]
|
|
pure (lBS2sT name, fmap lBS2sT 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] (fS "\\b" <> fS n <> fS "\\b")
|
|
)
|
|
$ t
|
|
verRe =
|
|
join
|
|
. fmap (ICU.group 0)
|
|
. ICU.find
|
|
(ICU.regex [ICU.CaseInsensitive] (fS "\\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
|
|
True <- doesFileExist debian_version
|
|
ver <- readFile debian_version
|
|
pure (T.pack "debian", Just $ lBS2sT ver)
|
|
|
|
|
|
-- | 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?
|
|
-> 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))
|
|
|
|
-- | 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' :: 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
|
|
_ -> fail ("Don't know how to handle URL: " <> exportURL url)
|
|
|
|
|
|
-- | Same as 'download', except with a file descriptor. Allows to e.g.
|
|
-- print to stdout.
|
|
downloadFd :: Bool -- ^ https?
|
|
-> String -- ^ host (e.g. "www.example.com")
|
|
-> String -- ^ path (e.g. "/my/file")
|
|
-> Maybe Integer -- ^ 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
|
|
-> String
|
|
-> String
|
|
-> Maybe Integer
|
|
-> 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 (C.pack host) (fromIntegral $ fromMaybe 443 port)
|
|
False -> openConnection (C.pack host) (fromIntegral $ fromMaybe 80 port)
|
|
|
|
let q = buildRequest1 $ http GET (C.pack "/" <> C.pack 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 ->
|
|
-- ...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' <- parseRel (C.pack $ T.unpack x)
|
|
let fp = dest </> fn'
|
|
fmap (, fp) $ createRegularFileFd newFilePerms fp
|
|
Nothing -> do
|
|
-- ...if all fails, use a random filename!
|
|
(fp, handle) <- (mkstemp (toFilePath dest))
|
|
path <- parseAbs fp
|
|
fd <- handleToFd handle
|
|
pure (fd, path)
|
|
|
|
|
|
|
|
|
|
-- unpack :: Path Abs -> IO (Path Abs)
|
|
-- unpack = undefined
|
|
|
|
-- install :: DownloadURL -> IO (Path Abs)
|
|
-- install = undefined
|
|
|
|
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
|
-- parseAvailableDownloads = undefined
|