DetectFirefox.hs

{-# LANGUAGE CPP #-}

module Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox (
  detectFirefoxVersion
  , getGeckoDriverVersion
  , getGeckoDriverDownloadUrl
  ) where

import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson as A
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Safe
import System.Exit
import System.Process
import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Internal.Util

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap          as HM
#else
import qualified Data.HashMap.Strict        as HM
#endif


detectFirefoxVersion :: Maybe FilePath -> IO (Either T.Text FirefoxVersion)
detectFirefoxVersion maybeFirefoxPath = leftOnException $ runExceptT $ do
  let firefoxToUse = fromMaybe "firefox" maybeFirefoxPath
  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (firefoxToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+(\\.[0-9]+)?\"")) ""

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

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


getGeckoDriverVersion :: Maybe FilePath -> IO (Either T.Text GeckoDriverVersion)
getGeckoDriverVersion _maybeFirefoxPath = runExceptT $ do
  -- firefoxVersion <- ExceptT $ liftIO $ detectFirefoxVersion maybeFirefoxPath

  -- Just get the latest release on GitHub
  let url = [i|https://api.github.com/repos/mozilla/geckodriver/releases/latest|]
  req <- parseRequest url
  manager <- liftIO newTlsManager
  ExceptT $
    handle (\(e :: HttpException) -> return $ Left [i|Error when requesting '#{url}': '#{e}'|])
           (do
               result <- httpLbs (req { requestHeaders = ("User-Agent", "foo") : (requestHeaders req) }) manager
               case A.eitherDecode $ responseBody result of
                 Right (A.Object (HM.lookup "tag_name" -> Just (A.String tag))) -> do
                   let parts = T.splitOn "." $ T.drop 1 tag
                   case parts of
                     [tReadMay -> Just x, tReadMay -> Just y] -> return $ Right $ GeckoDriverVersion (x, y, 0)
                     [tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ GeckoDriverVersion (x, y, z)
                     _ -> return $ Left [i|Unexpected geckodriver release tag: '#{tag}'|]
                 val -> return $ Left [i|Failed to decode GitHub releases: '#{val}'|]
           )


getGeckoDriverDownloadUrl :: GeckoDriverVersion -> Platform -> T.Text
getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Linux = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-linux64.tar.gz|]
getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) OSX = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-macos.tar.gz|]
getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Windows = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-win32.tar.gz|]

-- * Util

tReadMay = readMay . T.unpack