nvfetcher-0.8.0.0: test/Utils.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Utils where

import Control.Concurrent.Async
import Control.Concurrent.Extra
import Control.Concurrent.STM
import Control.Exception (Handler (..), SomeException, bracket, catches, throwIO)
import Control.Monad (void)
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Default (def)
import Data.Map (Map)
import Data.Maybe (isJust)
import Development.Shake
import Development.Shake.Database
import NvFetcher.Config
import NvFetcher.Core (coreRules)
import NvFetcher.Types
import NvFetcher.Types.ShakeExtras
import qualified System.Directory.Extra as Extra
import qualified System.IO.Extra as Extra
import System.Time.Extra
import Test.Hspec
import UnliftIO (MonadUnliftIO (withRunInIO))

--------------------------------------------------------------------------------

runAction :: ActionQueue -> Action a -> IO (Maybe a)
runAction chan x = do
  barrier <- newBarrier
  atomically $ writeTQueue chan $ x >>= liftIO . signalBarrier barrier
  -- TODO
  timeout 30 $ waitBarrier barrier

type ActionQueue = TQueue (Action ())

newAsyncActionQueue :: Map PackageKey Package -> Config -> IO (ActionQueue, Async ())
newAsyncActionQueue pkgs config = Extra.withTempDir $ \dir -> do
  shakeExtras <- liftIO $ initShakeExtras config {buildDir = dir} pkgs mempty
  chan <- atomically newTQueue
  (getShakeDb, _) <-
    shakeOpenDatabase
      shakeOptions
        { shakeExtra = addShakeExtra shakeExtras (shakeExtra shakeOptions),
          shakeFiles = dir,
          shakeVerbosity = Quiet
        }
      coreRules
  shakeDb <- getShakeDb

  let runner restore = do
        -- sequentially
        act <- liftIO $ atomically $ readTQueue chan
        catches
          (restore $ void $ shakeRunDatabase shakeDb [act])
          [ Handler $ \(e :: AsyncCancelled) -> throwIO e,
            Handler $ \(e :: SomeException) -> putStrLn $ "an exception arose in action runner: " <> show e
          ]
        runner restore

  runnerTask <- asyncWithUnmask $ \r -> runner r
  pure (chan, runnerTask)

--------------------------------------------------------------------------------

aroundShake :: SpecWith ActionQueue -> Spec
aroundShake = aroundShake' mempty def

aroundShake' :: Map PackageKey Package -> Config -> SpecWith ActionQueue -> Spec
aroundShake' pkgs config = aroundAll $ \f ->
  bracket
    (newAsyncActionQueue pkgs config)
    (\(_, runnerTask) -> cancel runnerTask)
    (\(chan, _) -> f chan)

shouldReturnJust :: (Show a, Eq a, MonadUnliftIO m) => m (Maybe a) -> a -> m ()
shouldReturnJust f x = withRunInIO $ \run -> run f `shouldReturn` Just x

shouldBeJust :: (MonadIO m, Show a) => Maybe a -> m ()
shouldBeJust x = liftIO $ x `shouldSatisfy` isJust

shouldExist :: (MonadIO m) => FilePath -> m ()
shouldExist path = liftIO $ Extra.doesFileExist path `shouldReturn` True

specifyChan :: (HasCallStack) => String -> ReaderT ActionQueue IO () -> SpecWith ActionQueue
specifyChan s m = specify s $ \r -> runReaderT m r

runActionChan :: Action a -> ReaderT ActionQueue IO (Maybe a)
runActionChan m = ask >>= \chan -> liftIO $ runAction chan m