{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

module Xrefcheck.System
    ( readingSystem
    , askWithinCI
    , RelGlobPattern (..)
    , bindGlobPattern
    ) where

import Data.Aeson (FromJSON (..), withText)
import qualified Data.Char as C
import GHC.IO.Unsafe (unsafePerformIO)
import System.Directory (canonicalizePath)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import qualified System.FilePath.Glob as Glob

-- | We can quite safely treat surrounding filesystem as frozen,
-- so IO reading operations can be turned into pure values.
readingSystem :: IO a -> a
readingSystem :: IO a -> a
readingSystem = IO a -> a
forall a. IO a -> a
unsafePerformIO

-- | Heuristics to check whether we are running within CI.
-- Check the respective env variable which is usually set in all CIs.
askWithinCI :: IO Bool
askWithinCI :: IO Bool
askWithinCI = String -> IO (Maybe String)
lookupEnv String
"CI" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
  Just String
"1"                       -> Bool
True
  Just ((Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Char
C.toLower -> String
"true") -> Bool
True
  Maybe String
_                              -> Bool
False

-- | Glob pattern relative to repository root.
newtype RelGlobPattern = RelGlobPattern FilePath

bindGlobPattern :: FilePath -> RelGlobPattern -> Glob.Pattern
bindGlobPattern :: String -> RelGlobPattern -> Pattern
bindGlobPattern String
root (RelGlobPattern String
relPat) = IO Pattern -> Pattern
forall a. IO a -> a
readingSystem (IO Pattern -> Pattern) -> IO Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ do
  -- TODO [#26] try to avoid using canonicalization
  String
absPat <- String -> IO String
canonicalizePath (String
root String -> String -> String
</> String
relPat)
  case CompOptions -> String -> Either String Pattern
Glob.tryCompileWith CompOptions
globCompileOptions String
absPat of
    Left String
err ->
      Text -> IO Pattern
forall a. HasCallStack => Text -> a
error (Text -> IO Pattern) -> Text -> IO Pattern
forall a b. (a -> b) -> a -> b
$ Text
"Glob pattern compilation failed after canonicalization: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              String -> Text
forall a. ToText a => a -> Text
toText String
err
    Right Pattern
pat ->
      Pattern -> IO Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
pat

instance FromJSON RelGlobPattern where
    parseJSON :: Value -> Parser RelGlobPattern
parseJSON = String
-> (Text -> Parser RelGlobPattern)
-> Value
-> Parser RelGlobPattern
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Repo-relative glob pattern" ((Text -> Parser RelGlobPattern) -> Value -> Parser RelGlobPattern)
-> (Text -> Parser RelGlobPattern)
-> Value
-> Parser RelGlobPattern
forall a b. (a -> b) -> a -> b
$ \Text
path -> do
        let spath :: String
spath = Text -> String
forall a. ToString a => a -> String
toString Text
path
        -- Checking path is sane
        Pattern
_ <- CompOptions -> String -> Either String Pattern
Glob.tryCompileWith CompOptions
globCompileOptions String
spath
             Either String Pattern
-> (Either String Pattern -> Parser Pattern) -> Parser Pattern
forall a b. a -> (a -> b) -> b
& (String -> Parser Pattern)
-> (Pattern -> Parser Pattern)
-> Either String Pattern
-> Parser Pattern
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Pattern
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Pattern -> Parser Pattern
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        RelGlobPattern -> Parser RelGlobPattern
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RelGlobPattern
RelGlobPattern String
spath)

-- | Glob compilation options we use.
globCompileOptions :: Glob.CompOptions
globCompileOptions :: CompOptions
globCompileOptions = CompOptions
Glob.compDefault