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

-- TODO: handle SIGTERM, SIGUSR
module GHCup where


import qualified Codec.Archive.Tar             as Tar
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Trans.Maybe
import           Control.Monad.IO.Class
import           Control.Exception.Safe
import           Data.ByteString                ( ByteString )
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.Encoding as E
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           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
                                                , splitExtension
                                                )
import qualified System.Posix.FilePath         as FP
import           System.Posix.Env.ByteString    ( getEnvDefault )
import           System.Posix.Temp.ByteString
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)




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



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



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 :: (MonadCatch m, MonadIO m)
               => ToolRequest
               -> Maybe PlatformRequest
               -> URLSource
               -> Excepts
                    '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
                    m
                    URL
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
  (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
    GHCupURL      -> fail "Not implemented"
    OwnSource url -> fail "Not implemented"
    OwnSpec   dls -> pure dls

  lE $ 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
                -> Either NoDownload URL
getDownloadURL' 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 (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
  atJust x = at x % _Just


-- | 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          -- ^ destination dir
          -> Maybe (Path Rel)  -- ^ optional filename
          -> 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)




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


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



getPlatform :: (MonadCatch m, MonadIO m)
            => Excepts
                 '[PlatformResultError, DistroNotFound]
                 m
                 PlatformResult
getPlatform = 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
  where getFreeBSDVersion = pure Nothing


getLinuxDistro :: (MonadCatch m, MonadIO m)
               => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
  (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] (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"] Nothing
    ver <- (fmap . fmap) _stdOut
      $ executeOut lsb_release_cmd [fS "-sr"] Nothing
    pure (E.decodeUtf8 name, fmap 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] (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
    ver <- readFile debian_version
    pure (T.pack "debian", Just $ lBS2sT ver)



    ------------------------
    --[ GHC installation ]--
    ------------------------


-- TODO: quasiquote for ascii bytestrings


-- | Unpack an archive to a temporary directory and return that path.
unpackToTmpDir :: Path Abs       -- ^ archive path
               -> IO (Either ArchiveError (Path Abs))
unpackToTmpDir av = do
  fn <- basename av
  let (fnrest, ext) = splitExtension $ toFilePath fn
  let ext2          = takeExtension fnrest
  tmpdir <- getEnvDefault (fS "TMPDIR") (fS "/tmp")
  tmp    <- mkdtemp $ (tmpdir FP.</> fS "ghcup-")
  let untar bs = do
        Tar.unpack tmp . Tar.read $ bs
        Right <$> parseAbs tmp

  -- extract, depending on file extension
  if
    | ext == fS ".gz" && ext2 == fS ".tar"
    -> untar . GZip.decompress =<< readFile av
    | ext == fS ".xz" && ext2 == fS ".tar"
    -> do
      filecontents <- readFile av
      let decompressed = Lzma.decompress filecontents
      -- putStrLn $ show decompressed
      untar decompressed
    | ext == fS ".bz2" && ext2 == fS ".tar"
    -> untar . BZip.decompress =<< readFile av
    | ext == fS ".tar" && ext2 == fS ".tar"
    -> untar =<< readFile av
    | otherwise
    -> pure $ Left $ UnknownArchive ext

 where
  isTar ext | ext == fS ".tar" = pure ()
            | otherwise        = throwE $ UnknownArchive ext


-- | Install an unpacked GHC distribution.
installGHC :: Path Abs      -- ^ Path to the unpacked GHC bindist
           -> Path Abs      -- ^ Path to install to
           -> IO ()
installGHC path inst = do
  exe (fS "./configure") [fS "--prefix=" <> toFilePath inst] False (Just path)
  -- sh (fS "make") [fS "install"] (Just path)
  pure ()

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