-- | Provide information about the current build.
--
-- This module provides build meta information like
-- build directory, build-id and build-time.
--
-- @since 0.5.65
module B9.BuildInfo
  ( getBuildId,
    getBuildDate,
    getBuildDir,
    withBuildInfo,
    BuildInfoReader,
    isInteractive,
  )
where

import B9.B9Config
import B9.B9Error
import B9.B9Logging
import B9.Environment
import Control.Eff
import Control.Eff.Reader.Lazy
import Control.Exception (bracket)
import Control.Lens ((?~))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
  ( MonadBaseControl,
    control,
  )
import Data.Functor ()
import Data.Hashable
import Data.Time.Clock
import Data.Time.Format
import GHC.Stack
import System.Directory
import System.FilePath
import System.IO.B9Extras
import Text.Printf

-- | Build meta information.
--
-- @since 0.5.65
data BuildInfo
  = BuildInfo
      { BuildInfo -> String
bsBuildId :: String,
        BuildInfo -> String
bsBuildDate :: String,
        BuildInfo -> String
bsBuildDir :: FilePath,
        BuildInfo -> UTCTime
bsStartTime :: UTCTime,
        BuildInfo -> Bool
bsIsInteractive :: Bool
      }
  deriving (BuildInfo -> BuildInfo -> Bool
(BuildInfo -> BuildInfo -> Bool)
-> (BuildInfo -> BuildInfo -> Bool) -> Eq BuildInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildInfo -> BuildInfo -> Bool
$c/= :: BuildInfo -> BuildInfo -> Bool
== :: BuildInfo -> BuildInfo -> Bool
$c== :: BuildInfo -> BuildInfo -> Bool
Eq, Int -> BuildInfo -> ShowS
[BuildInfo] -> ShowS
BuildInfo -> String
(Int -> BuildInfo -> ShowS)
-> (BuildInfo -> String)
-> ([BuildInfo] -> ShowS)
-> Show BuildInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildInfo] -> ShowS
$cshowList :: [BuildInfo] -> ShowS
show :: BuildInfo -> String
$cshow :: BuildInfo -> String
showsPrec :: Int -> BuildInfo -> ShowS
$cshowsPrec :: Int -> BuildInfo -> ShowS
Show)

-- | Type alias for a 'BuildInfo' 'Reader'
--
-- @since 0.5.65
type BuildInfoReader = Reader BuildInfo

-- | Create the build directories, generate (hash) the build-id and execute the given action.
--
-- Bindings added to the text template parameter environment:
--
-- * @projectRoot@ the directory that contains the sources of the project to build
-- * @buildDir@ the temporary directory used store the build artifacts passed into- or outof the build
--
-- Unless '_keepTempDirs' is @True@ clean up the build directories after the actions
-- returns - even if the action throws a runtime exception.
--
-- @since 0.5.65
withBuildInfo ::
  ( Lifted IO e,
    MonadBaseControl IO (Eff e),
    Member B9ConfigReader e,
    Member ExcB9 e,
    Member EnvironmentReader e,
    Member LoggerReader e,
    HasCallStack
  ) =>
  Bool ->
  Eff (BuildInfoReader ': e) a ->
  Eff e a
withBuildInfo :: Bool -> Eff (BuildInfoReader : e) a -> Eff e a
withBuildInfo Bool
interactive Eff (BuildInfoReader : e) a
action = Eff e a -> Eff e a
forall (e :: [* -> *]) b.
(SetMember Lift (Lift IO) e, FindElem (Reader B9Config) e,
 FindElem (Reader Environment) e, FindElem (Exc SomeException) e) =>
Eff e b -> Eff e b
withRootDir (Eff e a -> Eff e a) -> Eff e a -> Eff e a
forall a b. (a -> b) -> a -> b
$ do
  UTCTime
now <- IO UTCTime -> Eff e UTCTime
forall (m :: * -> *) (r :: [* -> *]) a.
Lifted m r =>
m a -> Eff r a
lift IO UTCTime
getCurrentTime
  let buildDate :: String
buildDate = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
forall a. HasCallStack => a
undefined String
"%F-%T" UTCTime
now -- TODO make configurable how the build date is formatted
  String
buildId <- Eff e String
generateBuildId 
  String -> (String -> Eff e a) -> Eff e a
forall (e :: [* -> *]) a b.
(MonadBaseControl IO (Eff e), FindElem (Reader B9Config) e,
 StM (Eff e) a ~ StM (Eff e) b) =>
String -> (String -> Eff e a) -> Eff e b
withBuildDir String
buildId (String -> String -> UTCTime -> String -> Eff e a
runImpl String
buildId String
buildDate UTCTime
now)
  where
    withRootDir :: Eff e b -> Eff e b
withRootDir Eff e b
f = do
      Maybe String
mRoot <- B9Config -> Maybe String
_projectRoot (B9Config -> Maybe String)
-> Eff e B9Config -> Eff e (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]).
Member (Reader B9Config) e =>
Eff e B9Config
getB9Config
      String
root <- IO String -> Eff e String
forall (m :: * -> *) (r :: [* -> *]) a.
Lifted m r =>
m a -> Eff r a
lift (IO String -> Eff e String) -> IO String -> Eff e String
forall a b. (a -> b) -> a -> b
$ case Maybe String
mRoot of
        Maybe String
Nothing -> IO String
getCurrentDirectory IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
canonicalizePath
        Just String
rootIn -> do
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
rootIn
          String -> IO String
canonicalizePath String
rootIn
      (B9Config -> B9Config) -> Eff e b -> Eff e b
forall (e :: [* -> *]) a.
Member (Reader B9Config) e =>
(B9Config -> B9Config) -> Eff e a -> Eff e a
localB9Config
        ((Maybe String -> Identity (Maybe String))
-> B9Config -> Identity B9Config
Lens' B9Config (Maybe String)
projectRoot ((Maybe String -> Identity (Maybe String))
 -> B9Config -> Identity B9Config)
-> String -> B9Config -> B9Config
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ String
root)
        ((String, String) -> Eff e b -> Eff e b
forall (e :: [* -> *]) a.
(Member (Reader Environment) e, Member (Exc SomeException) e) =>
(String, String) -> Eff e a -> Eff e a
addLocalStringBinding (String
"projectRoot", String
root) Eff e b
f)
    generateBuildId :: Eff e String
generateBuildId = do
      -- TODO generate a proper, reproducable build id!
      Bool
unqiueBuildDir <- B9Config -> Bool
_uniqueBuildDirs (B9Config -> Bool) -> Eff e B9Config -> Eff e Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]).
Member (Reader B9Config) e =>
Eff e B9Config
getB9Config
      Int
cfgHash <- String -> Int
forall a. Hashable a => a -> Int
hash (String -> Int) -> (B9Config -> String) -> B9Config -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. B9Config -> String
forall a. Show a => a -> String
show (B9Config -> Int) -> Eff e B9Config -> Eff e Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]).
Member (Reader B9Config) e =>
Eff e B9Config
getB9Config
      Int
actionHash <- String -> Int
forall a. Hashable a => a -> Int
hash (String -> Int) -> (UUID -> String) -> UUID -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
forall a. Show a => a -> String
show (UUID -> Int) -> Eff e UUID -> Eff e Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e UUID
forall (m :: * -> *). MonadIO m => m UUID
randomUUID -- TODO use the actual hash of the input
      if Bool
unqiueBuildDir
        then String -> Eff e String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%08X-%08X" Int
cfgHash (Int -> Int
forall a. Hashable a => a -> Int
hash Int
actionHash))
        else String -> Eff e String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%08X" Int
cfgHash)
    withBuildDir :: String -> (String -> Eff e a) -> Eff e b
withBuildDir String
buildId String -> Eff e a
f = do
      Maybe String
root <- B9Config -> Maybe String
_projectRoot (B9Config -> Maybe String)
-> Eff e B9Config -> Eff e (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]).
Member (Reader B9Config) e =>
Eff e B9Config
getB9Config
      B9Config
cfg <- Eff e B9Config
forall (e :: [* -> *]).
Member (Reader B9Config) e =>
Eff e B9Config
getB9Config
      (RunInBase (Eff e) IO -> IO (StM (Eff e) b)) -> Eff e b
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase (Eff e) IO -> IO (StM (Eff e) b)) -> Eff e b)
-> (RunInBase (Eff e) IO -> IO (StM (Eff e) b)) -> Eff e b
forall a b. (a -> b) -> a -> b
$ \RunInBase (Eff e) IO
runInIO ->
        IO String
-> (String -> IO ())
-> (String -> IO (StM (Eff e) b))
-> IO (StM (Eff e) b)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Maybe String -> IO String
createBuildDir Maybe String
root) (B9Config -> String -> IO ()
removeBuildDir B9Config
cfg) (Eff e a -> IO (StM (Eff e) b)
RunInBase (Eff e) IO
runInIO (Eff e a -> IO (StM (Eff e) b))
-> (String -> Eff e a) -> String -> IO (StM (Eff e) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Eff e a
f)
      where
        createBuildDir :: Maybe String -> IO String
createBuildDir Maybe String
root = do
          -- TODO allow config option to enable build dirs outside of the projectRoot
          let buildDir :: String
buildDir = case Maybe String
root of
                Just String
r -> String
r String -> ShowS
</> String
"BUILD-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
buildId
                Maybe String
Nothing -> String
"BUILD-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
buildId
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
buildDir
          String -> IO String
canonicalizePath String
buildDir
        removeBuildDir :: B9Config -> String -> IO ()
removeBuildDir B9Config
cfg String
buildDir =
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (B9Config -> Bool
_uniqueBuildDirs B9Config
cfg Bool -> Bool -> Bool
&& Bool -> Bool
not (B9Config -> Bool
_keepTempDirs B9Config
cfg)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
removeDirectoryRecursive String
buildDir
    runImpl :: String -> String -> UTCTime -> String -> Eff e a
runImpl String
buildId String
buildDate UTCTime
startTime String
buildDir =
      let ctx :: BuildInfo
ctx = String -> String -> String -> UTCTime -> Bool -> BuildInfo
BuildInfo String
buildId String
buildDate String
buildDir UTCTime
startTime Bool
interactive
       in BuildInfo -> Eff (BuildInfoReader : e) a -> Eff e a
forall e (r :: [* -> *]) w. e -> Eff (Reader e : r) w -> Eff r w
runReader BuildInfo
ctx Eff (BuildInfoReader : e) a
wrappedAction
      where
        wrappedAction :: Eff (BuildInfoReader : e) a
wrappedAction = do
          String
rootD <- Eff (BuildInfoReader : e) String
forall (e :: [* -> *]). Member (Reader B9Config) e => Eff e String
getProjectRoot
          String -> Eff (BuildInfoReader : e) ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Project Root Directory: %s" String
rootD)
          String
buildD <- Eff (BuildInfoReader : e) String
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e String
getBuildDir
          String -> Eff (BuildInfoReader : e) ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
traceL (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Build Directory:        %s" String
buildD)
          a
r <- (String, String)
-> Eff (BuildInfoReader : e) a -> Eff (BuildInfoReader : e) a
forall (e :: [* -> *]) a.
(Member (Reader Environment) e, Member (Exc SomeException) e) =>
(String, String) -> Eff e a -> Eff e a
addLocalStringBinding (String
"buildDir", String
buildD) Eff (BuildInfoReader : e) a
action
          UTCTime
tsAfter <- IO UTCTime -> Eff (BuildInfoReader : e) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          let duration :: String
duration = NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime
tsAfter UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
startTime)
          String -> Eff (BuildInfoReader : e) ()
forall (e :: [* -> *]). CommandIO e => String -> Eff e ()
infoL (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"DURATION: %s" String
duration)
          a -> Eff (BuildInfoReader : e) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- Run the action build action
getBuildId :: Member BuildInfoReader e => Eff e String
getBuildId :: Eff e String
getBuildId = BuildInfo -> String
bsBuildId (BuildInfo -> String) -> Eff e BuildInfo -> Eff e String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e BuildInfo
forall e (r :: [* -> *]). Member (Reader e) r => Eff r e
ask

getBuildDate :: Member BuildInfoReader e => Eff e String
getBuildDate :: Eff e String
getBuildDate = BuildInfo -> String
bsBuildDate (BuildInfo -> String) -> Eff e BuildInfo -> Eff e String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e BuildInfo
forall e (r :: [* -> *]). Member (Reader e) r => Eff r e
ask

getBuildDir :: Member BuildInfoReader e => Eff e FilePath
getBuildDir :: Eff e String
getBuildDir = BuildInfo -> String
bsBuildDir (BuildInfo -> String) -> Eff e BuildInfo -> Eff e String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e BuildInfo
forall e (r :: [* -> *]). Member (Reader e) r => Eff r e
ask

-- | Ask whether @stdin@ of the @B9@ process should be redirected to the
-- external commands executed during the build.
--
-- @since 2.0.0
isInteractive :: Member BuildInfoReader e => Eff e Bool
isInteractive :: Eff e Bool
isInteractive = BuildInfo -> Bool
bsIsInteractive (BuildInfo -> Bool) -> Eff e BuildInfo -> Eff e Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e BuildInfo
forall e (r :: [* -> *]). Member (Reader e) r => Eff r e
ask