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