{-# 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.Aeson
import           Data.Attoparsec.ByteString
import           Data.ByteString                ( ByteString )
import qualified Data.ByteString.Lazy          as L
import           Data.ByteString.Builder
import           Data.Foldable                  ( asum )
import           Data.String.QQ
import           Data.Text                      ( Text )
import           Data.Versions
import           Data.IORef
import           GHCup.Bash
import           GHCup.File
import           GHCup.Prelude
import           GHCup.Types
import           GHCup.Types.JSON
import           GHCup.Types.Optics
import           HPath
import           HPath.IO
import           Optics
import           Prelude                 hiding ( abs
                                                , readFile
                                                )
import           Data.List
import           System.Info
import           System.IO.Error
import           Data.Foldable                  ( foldrM )
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
import           Data.String.Interpolate
import           Safe


data Settings = Settings
  { cache     :: Bool
  , urlSource :: URLSource
  }
  deriving Show

getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource

getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache



    ---------------------------
    --[ 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

data NotSet = NotSet Tool
  deriving Show

data JSONError = JSONDecodeError String
  deriving Show

data ParseError = ParseError String
  deriving Show

instance Exception ParseError



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


ghcupURL :: URI
ghcupURL =
  [uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]


-- | 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


getDownloads :: ( FromJSONKey Tool
                , FromJSONKey Version
                , FromJSON VersionInfo
                , MonadIO m
                , MonadReader Settings m
                )
             => Excepts '[URLException , JSONError] m AvailableDownloads
getDownloads = lift getUrlSource >>= \case
  GHCupURL -> do
    bs <- liftE $ downloadBS ghcupURL
    lE' JSONDecodeError $ eitherDecode' bs
  (OwnSource uri) -> do
    bs <- liftE $ downloadBS uri
    lE' JSONDecodeError $ eitherDecode' bs
  (OwnSpec av) -> pure $ av



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


getDownloadInfo :: ( MonadLogger m
                   , MonadCatch m
                   , MonadIO m
                   , MonadReader Settings m
                   )
                => ToolRequest
                -> Maybe PlatformRequest
                -> Excepts
                     '[ PlatformResultError
                      , NoDownload
                      , NoCompatibleArch
                      , DistroNotFound
                      , URLException
                      , JSONError
                      ]
                     m
                     DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq = do
  urlSource <- lift getUrlSource
  lift $ $(logDebug) [i|Receiving download info from: #{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 <- liftE $ getDownloads

  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


-- | 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
    let uri = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
    lift $ $(logInfo) [i|downloading: #{uri}|]
    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


downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString
downloadBS uri | view (uriSchemeL' % schemeBSL') uri == [s|https|] = dl True
               | view (uriSchemeL' % schemeBSL') uri == [s|http|] = dl False
               | otherwise = throwE UnsupportedURL

 where
  dl https = do
    host <-
      preview (authorityL' % _Just % authorityHostL' % hostBSL') uri
        ?? UnsupportedURL
    let path = view pathL' uri
    let port = preview
          (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
          uri
    liftIO $ downloadBS' https host path port


-- | 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
  (fd, fp) <- getFile
  let stepper = fdWrite fd
  flip finally (closeFd fd) $ downloadInternal https host path port stepper
  pure fp
 where
  -- Manage to find a file we can write the body into.
  getFile :: IO (Fd, Path Abs)
  getFile = 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


-- | Load the result of this download into memory at once.
downloadBS' :: Bool             -- ^ https?
            -> ByteString       -- ^ host (e.g. "www.example.com")
            -> ByteString       -- ^ path (e.g. "/my/file")
            -> Maybe Int        -- ^ optional port (e.g. 3000)
            -> IO (L.ByteString)
downloadBS' https host path port = do
  bref <- newIORef (mempty :: Builder)
  let stepper bs = modifyIORef bref (<> byteString bs)
  downloadInternal https host path port stepper
  readIORef bref <&> toLazyByteString


downloadInternal :: Bool
                 -> ByteString
                 -> ByteString
                 -> Maybe Int
                 -> (ByteString -> IO a)        -- ^ the consuming step function
                 -> IO ()
downloadInternal https host path port consumer = 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 path

  sendRequest c q emptyBody

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

  closeConnection c



    --------------------------
    --[ 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) [i|Identified Platform as: #{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 also sets
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
--
-- 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
               , MonadFail m
               )
            => ToolRequest
            -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
            -> Excepts
                 '[ AlreadyInstalled
                  , FileError
                  , ArchiveError
                  , ProcessError
                  , URLException
                  , PlatformResultError
                  , NoDownload
                  , NoCompatibleArch
                  , DistroNotFound
                  , NotInstalled
                  , URLException
                  , JSONError
                  ]
                 m
                 ()
installTool treq mpfReq = do
  lift $ $(logDebug) [i|Requested to install: #{treq}|]
  alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
  when alreadyInstalled $ (throwE $ AlreadyInstalled treq)

  Settings {..} <- lift ask

  -- download (or use cached version)
  dlinfo        <- liftE $ getDownloadInfo treq mpfReq
  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)

  case treq of
    (ToolRequest GHC ver) -> do
      liftE $ installGHC archiveSubdir ghcdir
      liftE $ setGHC ver SetGHCMinor

      -- Create ghc-x.y symlinks. This may not be the current
      -- version, create it regardless.
      (mj, mi) <- liftIO $ getGHCMajor ver
      getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
    (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. This only deals with the GHC build system and nothing else.
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
  liftIO $ createDirIfMissing newDirPerms inst
  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
    (path </> cabalFile)
    (inst </> cabalFile)
    Overwrite



    ---------------
    --[ Set GHC ]--
    ---------------



-- | 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
--   * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
--   * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
--
-- 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 = verToBS ver
  ghcdir  <- liftIO $ ghcupGHCDir ver

  -- symlink destination
  destdir <- liftIO $ ghcupBinDir
  liftIO $ createDirIfMissing newDirPerms destdir

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

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

  pure ()

 where

  symlinkShareDir :: Path Abs -> ByteString -> IO ()
  symlinkShareDir ghcdir verBS = do
    destdir <- ghcupBaseDir
    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 ()




    ------------------
    --[ List tools ]--
    ------------------


data ListCriteria = ListInstalled
                  | ListSet
                  deriving Show

data ListResult = ListResult
  { lTool      :: Tool
  , lVer       :: Version
  , lTag       :: [Tag]
  , lInstalled :: Bool
  , lSet       :: Bool
  }
  deriving Show


availableToolVersions :: AvailableDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf
  (ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
  av


listVersions :: (MonadReader Settings m, MonadIO m)
             => Maybe Tool
             -> Maybe ListCriteria
             -> Excepts '[URLException , JSONError] m [ListResult]
listVersions lt criteria = do
  dls <- liftE $ getDownloads
  liftIO $ listVersions' dls lt criteria


listVersions' :: AvailableDownloads
              -> Maybe Tool
              -> Maybe ListCriteria
              -> IO [ListResult]
listVersions' av lt criteria = case lt of
  Just t -> do
    filter' <$> forM (availableToolVersions av t) (toListResult t)
  Nothing -> do
    ghcvers   <- listVersions' av (Just GHC) criteria
    cabalvers <- listVersions' av (Just Cabal) criteria
    pure (ghcvers <> cabalvers)

 where
  toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
  toListResult t (v, tags) = case t of
    GHC -> do
      lSet       <- fmap (maybe False (== v)) $ ghcSet
      lInstalled <- ghcInstalled v
      pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
    Cabal -> do
      lSet       <- fmap (== v) $ cabalSet
      lInstalled <- cabalInstalled v
      pure ListResult { lVer = v, lTag = tags, lTool = t, .. }

  filter' :: [ListResult] -> [ListResult]
  filter' lr = case criteria of
    Nothing            -> lr
    Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
    Just ListSet       -> filter (\ListResult {..} -> lSet) lr





    ------------------
    --[ List tools ]--
    ------------------


-- | This function may throw and crash in various ways.
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
         => Version
         -> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
  isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
  dir      <- liftIO $ ghcupGHCDir ver
  let d' = toFilePath dir
  let v' = prettyVer ver
  exists <- liftIO $ doesDirectoryExist dir

  toolsFiles <- liftE $ ghcToolFiles ver

  if exists
    then do
      -- this isn't atomic
      lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
      liftIO $ deleteDirRecursive dir

      lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
      liftIO $ rmMinorSymlinks

      lift $ $(logInfo) [i|Removing ghc-x.y symlinks|]
      liftE fixMajorSymlinks

      when isSetGHC $ liftE $ do
        lift $ $(logInfo) [i|Removing ghc symlinks|]
        rmPlain dir toolsFiles

      liftIO
        $   ghcupBaseDir
        >>= hideError doesNotExistErrorType
        .   deleteFile
        .   (</> ([rel|share|] :: Path Rel))
    else throwE (NotInstalled $ ToolRequest GHC ver)

 where
  -- e.g. ghc-8.6.5
  rmMinorSymlinks :: IO ()
  rmMinorSymlinks = do
    bindir <- ghcupBinDir
    files  <- getDirsFiles' bindir
    let myfiles = filter
          (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
          files
    forM_ myfiles $ \f -> deleteFile (bindir </> f)

  -- E.g. ghc, if this version is the set one.
  -- This reads `ghcupGHCDir`.
  rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
          => Path Abs
          -> [Path Rel] -- ^ tools files
          -> Excepts '[NotInstalled] m ()
  rmPlain ghcDir files = do
    bindir <- liftIO $ ghcupBinDir
    forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)

  -- e.g. ghc-8.6
  fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
                   => Excepts '[NotInstalled] m ()
  fixMajorSymlinks = do
    (mj, mi) <- getGHCMajor ver
    let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi

    bindir <- liftIO $ ghcupBinDir

    -- first delete them
    files  <- liftIO $ getDirsFiles' bindir
    let myfiles =
          filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
    forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)

    -- then fix them (e.g. with an earlier version)
    getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)




    -----------------
    --[ 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 (verToBS ver)
  pure (ghcbasedir </> verdir)


-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
                   -> Version
                   -> ByteString
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool


-- | Extract the version part of the result of `ghcLinkDestination`.
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
 where
  parser    = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
  verParser = many1' (notWord8 _slash) >>= \t ->
    case version $ E.decodeUtf8 $ B.pack t of
      Left  e -> fail $ show e
      Right r -> pure r


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


ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
ghcSet = do
  ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir

  -- link destination is of the form ../ghc/<ver>/bin/ghc
  liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
    link <- readSymbolicLink $ toFilePath ghcBin
    Just <$> ghcLinkVersion link

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 == (verToBS ver))

cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet = do
  cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
  mc       <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
  let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
  case version (E.decodeUtf8 reportedVer) of
    Left  e -> throwM e
    Right r -> pure r

-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
getGHCMajor ver = do
  SemVer {..} <- throwEither (semver $ prettyVer ver)
  pure (fromIntegral _svMajor, fromIntegral _svMinor)


-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadIO m, MonadThrow m)
               => Int -- ^ major version component
               -> Int -- ^ minor version component
               -> m (Maybe Version)
getGHCForMajor major minor = do
  p       <- liftIO $ ghcupGHCBaseDir
  ghcs    <- liftIO $ getDirsFiles' p
  semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
  mapM (throwEither . version)
    . fmap prettySemVer
    . lastMay
    . sort
    . filter
        (\SemVer {..} ->
          fromIntegral _svMajor == major && fromIntegral _svMinor == minor
        )
    $ semvers


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
  let fp = E.decodeUtf8 (toFilePath av)
  lift $ $(logInfo) [i|Unpacking: #{fp}|]
  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


-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
             => Version
             -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
  ghcdir <- liftIO $ ghcupGHCDir ver

  -- 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