DetectChrome.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}

module Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (
  detectChromeVersion
  , getChromeDriverVersion
  , getChromeDriverDownloadUrl
  ) where

import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson as A
import qualified Data.ByteString.Lazy as LB
import Data.Function
import Data.Map as M hiding (mapMaybe)
import Data.Maybe (mapMaybe)
import Data.String.Interpolate
import Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import GHC.Generics
import Network.HTTP.Client
import Network.HTTP.Conduit (simpleHttp)
import Safe
import System.Directory (findExecutable)
import System.Exit
import qualified System.Info as SI
import System.Process
import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Internal.Util


data PlatformAndUrl = PlatformAndUrl {
  platform :: Text
  , url :: Text
  } deriving (Show, Generic, FromJSON, ToJSON)

data Version = Version {
  version :: Text
  , revision :: Text
  , downloads :: Map Text [PlatformAndUrl]
  } deriving (Show, Generic, FromJSON, ToJSON)

data JsonResponse = JsonResponse {
  timestamp :: Text
  , versions :: [Version]
  } deriving (Show, Generic, FromJSON, ToJSON)

findChromeInEnvironment :: IO String
findChromeInEnvironment =
  flip fix candidates $ \loop cs -> case cs of
    [] -> pure "google-chrome" -- Give up
    (candidate:rest) -> findExecutable candidate >>= \case
      Nothing -> loop rest
      Just _ -> pure candidate
  where
    candidates = [
      "google-chrome"
      , "google-chrome-stable" -- May be found on NixOS
      ]

detectChromeVersion :: Maybe FilePath -> IO (Either T.Text ChromeVersion)
detectChromeVersion maybeChromePath = leftOnException $ runExceptT $ do
  chromeToUse <- liftIO $ maybe findChromeInEnvironment pure maybeChromePath

  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (chromeToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\"")) ""

  rawString <- case exitCode of
    ExitFailure _ -> throwE [i|Couldn't parse google-chrome version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]
    ExitSuccess -> return $ T.strip $ T.pack stdout

  case T.splitOn "." rawString of
    [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ ChromeVersion (w, x, y, z)
    _ -> throwE [i|Failed to parse google-chrome version from string: '#{rawString}'|]

getChromeDriverVersion :: Maybe FilePath -> IO (Either T.Text ChromeDriverVersion)
getChromeDriverVersion maybeChromePath = runExceptT $ do
  chromeVersion <- ExceptT $ liftIO $ detectChromeVersion maybeChromePath
  ExceptT $ getChromeDriverVersion' chromeVersion

getChromeDriverVersion' :: ChromeVersion -> IO (Either T.Text ChromeDriverVersion)
getChromeDriverVersion' (ChromeVersion (w, x, y, z))
  | w < 115 = do
      let url = [i|https://chromedriver.storage.googleapis.com/LATEST_RELEASE_#{w}.#{x}.#{y}|]
      handle (\(e :: HttpException) -> do
                return $ Left [i|Error when requesting '#{url}': '#{e}'|]
             )
             (do
                 result :: T.Text <- (TL.toStrict . TL.decodeUtf8) <$> simpleHttp url
                 case T.splitOn "." result of
                   [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ ChromeDriverVersionTuple (w, x, y, z)
                   _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|]
             )
  | otherwise = do
      let url = [i|https://googlechromelabs.github.io/chrome-for-testing/known-good-versions-with-downloads.json|]
      handle (\(e :: HttpException) -> do
                return $ Left [i|Error when requesting '#{url}': '#{e}'|]
             )
             (do
                 result :: LB.ByteString <- simpleHttp url
                 case A.eitherDecode result of
                   Left err -> return $ Left [i|Failed to decode response from '#{url}': #{err}|]
                   Right (response :: JsonResponse) -> do
                     let matchingVersions = [v | v@(Version {..}) <- versions response
                                               , [i|#{w}.#{x}.#{y}.|] `T.isPrefixOf` version]

                     let exactMatch = headMay [x | x@(Version {..}) <- matchingVersions
                                               , [i|#{w}.#{x}.#{y}.#{z}|] == version]

                     let versionList :: [Version]
                         versionList = (case exactMatch of Nothing -> id; Just x -> (x :)) matchingVersions

                     case headMay (mapMaybe extractSuitableChromeDriver versionList) of
                       Nothing -> return $ Left [i|Couldn't find chromedriver associated with any Chrome release|]
                       Just (tup, url) -> return $ Right $ ChromeDriverVersionExactUrl tup url
             )

extractSuitableChromeDriver :: Version -> Maybe ((Int, Int, Int, Int), Text)
extractSuitableChromeDriver (Version { version=(parseTuple -> Just tup), downloads=(M.lookup "chromedriver" -> Just platforms) }) =
  case headMay [url | PlatformAndUrl {platform, url} <- platforms
                    , platform == desiredPlatform] of
    Nothing -> Nothing
    Just url -> Just (tup, url)
  where
    desiredPlatform = case (SI.os, SI.arch) of
      ("windows", "x86_64") -> "win64"
      ("windows", "i386") -> "win32"
      ("mingw32", "x86_64") -> "win64"
      ("mingw32", "i386") -> "win32"

      ("darwin", "x86_64") -> "mac-x64"
      ("darwin", "arm") -> "mac-arm64"

      ("linux", _) -> "linux64"
      ("freebsd", _) -> "linux64"
      ("netbsd", _) -> "linux64"
      ("openbsd", _) -> "linux64"

      _ -> "unknown"
extractSuitableChromeDriver _ = Nothing

parseTuple :: Text -> Maybe (Int, Int, Int, Int)
parseTuple (T.splitOn "." -> [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z]) = Just (w, x, y, z)
parseTuple _ = Nothing

getChromeDriverDownloadUrl :: ChromeDriverVersion -> Platform -> T.Text
getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) Linux = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_linux64.zip|]
getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) OSX = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_mac64.zip|]
getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) Windows = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_win32.zip|]
getChromeDriverDownloadUrl (ChromeDriverVersionExactUrl _ url) _ = url

-- * Util

tReadMay = readMay . T.unpack