ghcup-hs/lib/GHCup.hs

{-# 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           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 qualified Data.Text                     as T
import qualified Data.Text.ICU                 as ICU
import           Data.Maybe                     ( isJust )
import qualified Data.Map.Strict               as Map


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"
                    )
                  ]
                )
              ]
            )
          ]
        )
      ]
    )
  ]
 where
  mkGHCUrl path = URL
    { url_type   = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
    , url_path   = path
    , url_params = []
    }


downloadURL :: ToolRequest
            -> Maybe PlatformRequest
            -> URLSource
            -> IO (Maybe URL) -- TODO: better error handling
downloadURL (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 $ downloadURL' t v arch plat ver dls


downloadURL' :: Tool
             -> Version
             -- ^ tool version
             -> Architecture
             -- ^ user arch
             -> Platform
             -- ^ user platform
             -> Maybe Versioning
             -- ^ optional version of the platform
             -> AvailableDownloads
             -> Maybe URL
downloadURL' 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 (T.pack <$> ["debian"])  -> Debian
        | hasWord name (T.pack <$> ["ubuntu"])  -> Ubuntu
        | hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint
        | hasWord name (T.pack <$> ["fedora"])  -> Fedora
        | hasWord name (T.pack <$> ["centos"])  -> CentOS
        | hasWord name (T.pack <$> ["Red Hat"]) -> RedHat
        | hasWord name (T.pack <$> ["alpine"])  -> Alpine
        | hasWord name (T.pack <$> ["exherbo"]) -> Exherbo
        | hasWord name (T.pack <$> ["gentoo"])  -> Gentoo
        | otherwise                             -> UnknownLinux
  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
    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 Fn
  lsb_release_cmd = [fn|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, _)) <- executeOut lsb_release_cmd [fS "-si"]
    ver              <- executeOut lsb_release_cmd [fS "-sr"]
    pure (lBS2sT name, fmap (lBS2sT . fst) 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)





-- download :: URL -> Path Abs -> IO (Path Abs)
-- download = undefined

-- unpack :: Path Abs -> IO (Path Abs)
-- unpack = undefined

-- install :: DownloadURL -> IO (Path Abs)
-- install = undefined

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