{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Tools.DBSynthesizer.Run
  ( CardanoProtocol
  , initialize
  , synthesize
  ) where

import qualified Cardano.Configuration as Cfg
import qualified Cardano.Configuration.CliArgs as CLI
import Cardano.Tools.Config
  ( mkHardForkTriggers
  , mkInitialNonce
  , mkProtocolVersion
  , mkTransitionConfig
  , reportConfigWarnings
  , resolveNodeConfigurationWith
  , throwConfigError
  )
import Cardano.Tools.Credentials (LeaderCredentials)
import qualified Cardano.Tools.Credentials as Creds
import Cardano.Tools.DBSynthesizer.Forging
import Cardano.Tools.DBSynthesizer.Types
import Control.Monad (filterM)
import Control.ResourceRegistry
import Control.Tracer
import Data.Bool (bool)
import Data.Functor (($>))
import qualified Data.Set as Set
import qualified Ouroboros.Consensus.Block.Forging as BlockForging
import Ouroboros.Consensus.Cardano
  ( ProtocolParamsByron (..)
  , ProtocolParamsShelleyBased (..)
  , defaultByronProtocolVersion
  , defaultByronSoftwareVersion
  )
import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Cardano.Node
  ( CardanoHardForkTriggers
  , CardanoProtocolParams (..)
  , protocolInfoCardano
  )
import Ouroboros.Consensus.Config
  ( TopLevelConfig
  , configStorage
  , emptyCheckpointsMap
  )
import qualified Ouroboros.Consensus.Node as Node (stdMkChainDbHasFS)
import qualified Ouroboros.Consensus.Node.InitStorage as Node
  ( nodeImmutableDbChunkInfo
  )
import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentClientTrace)
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import Ouroboros.Consensus.Shelley.Node
  ( ShelleyGenesis (..)
  , validateGenesis
  )
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
import Ouroboros.Consensus.Util.IOLike (atomically)
import Ouroboros.Network.Block hiding (GenesisHash)
import Ouroboros.Network.Point (WithOrigin (..))
import System.Directory
import System.FilePath ((</>))
import System.Random (newStdGen)

-- | A Cardano protocol ready to forge with: the 'ProtocolInfo' and the block
-- forgers that 'protocolInfoCardano' produces alongside it.
type CardanoProtocol =
  ( ProtocolInfo (CardanoBlock StandardCrypto)
  , Tracer IO KESAgentClientTrace ->
    IO [BlockForging.MkBlockForging IO (CardanoBlock StandardCrypto)]
  )

-- | Build the protocol to forge with from a node configuration file and the
-- forging credentials named on the command line.
--
-- The reading is done elsewhere: @cardano-config@ resolves the configuration and
-- loads every era's genesis, and "Cardano.Tools.Credentials" decodes the
-- credentials. What is left here is the mapping onto the consensus types.
--
-- A problem with either is thrown as a 'Cardano.Tools.Config.ConfigError', as in
-- the other tools, so the user gets a message rather than a backtrace.
--
-- The Shelley genesis comes back too because 'synthesize' needs its epoch
-- length.
initialize ::
  -- | The node configuration file.
  FilePath ->
  -- | The credential files, as named on the command line.
  Cfg.Credentials ->
  IO (ShelleyGenesis, CardanoProtocol)
initialize :: [Char] -> Credentials -> IO (ShelleyGenesis, CardanoProtocol)
initialize [Char]
configFile Credentials
creds = do
  (nc, warns) <- CliArgs -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfigurationWith CliArgs
cliArgs
  reportConfigWarnings warns

  triggers <- either throwConfigError pure $ mkHardForkTriggers (Cfg.testingConfiguration nc)
  let shelleyGenesis = NodeConfiguration -> ShelleyGenesis
Cfg.shelleyGenesisConfig NodeConfiguration
nc
  either throwConfigError pure $ validateGenesis shelleyGenesis
  leaderCredentials <-
    either throwConfigError pure
      =<< Creds.readLeaderCredentials (Cfg.byronGenesisConfig nc) (Cfg.credentials nc)

  -- The filesystem cardano-config names for the genesis initial-data injection
  -- files, rooted at the Shelley genesis' directory rather than the
  -- configuration file's. db-analyser mounts the same one.
  protocol <-
    protocolInfoCardano
      (Cfg.nodeConfigurationInjectionFS nc)
      (protocolParams nc triggers leaderCredentials)
  pure (shelleyGenesis, protocol)
 where
  -- db-synthesizer has no node command line of its own beyond the credentials,
  -- so everything else in the configuration comes from the file.
  cliArgs :: CliArgs
cliArgs = ([Char] -> CliArgs
CLI.defaultCliArgs [Char]
configFile){CLI.credentials = creds}

protocolParams ::
  Cfg.NodeConfiguration ->
  CardanoHardForkTriggers ->
  LeaderCredentials ->
  CardanoProtocolParams StandardCrypto
protocolParams :: NodeConfiguration
-> CardanoHardForkTriggers
-> LeaderCredentials
-> CardanoProtocolParams StandardCrypto
protocolParams NodeConfiguration
nc CardanoHardForkTriggers
triggers LeaderCredentials
leaderCredentials =
  ProtocolParamsByron
-> ProtocolParamsShelleyBased StandardCrypto
-> CardanoHardForkTriggers
-> TransitionConfig DijkstraEra
-> CheckpointsMap (CardanoBlock StandardCrypto)
-> ProtVer
-> CardanoProtocolParams StandardCrypto
forall c.
ProtocolParamsByron
-> ProtocolParamsShelleyBased c
-> CardanoHardForkTriggers
-> TransitionConfig DijkstraEra
-> CheckpointsMap (CardanoBlock c)
-> ProtVer
-> CardanoProtocolParams c
CardanoProtocolParams
    ProtocolParamsByron
      { byronGenesis :: Config
byronGenesis = NodeConfiguration -> Config
Cfg.byronGenesisConfig NodeConfiguration
nc
      , -- cardano-config removed the PBftSignatureThreshold key, so there is
        -- nothing to read: 'Nothing' makes 'protocolInfoByron' use consensus'
        -- own 'defaultPBftSignatureThreshold' of 0.22.
        byronPbftSignatureThreshold :: Maybe PBftSignatureThreshold
byronPbftSignatureThreshold = Maybe PBftSignatureThreshold
forall a. Maybe a
Nothing
      , -- What a forged Byron block announces about itself; see their haddocks.
        byronProtocolVersion :: ProtocolVersion
byronProtocolVersion = ProtocolVersion
defaultByronProtocolVersion
      , byronSoftwareVersion :: SoftwareVersion
byronSoftwareVersion = SoftwareVersion
defaultByronSoftwareVersion
      , byronLeaderCredentials :: Maybe ByronLeaderCredentials
byronLeaderCredentials = LeaderCredentials -> Maybe ByronLeaderCredentials
Creds.byronLeaderCredentials LeaderCredentials
leaderCredentials
      }
    ProtocolParamsShelleyBased
      { shelleyBasedInitialNonce :: Nonce
shelleyBasedInitialNonce = NodeConfiguration -> Nonce
mkInitialNonce NodeConfiguration
nc
      , shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials StandardCrypto]
shelleyBasedLeaderCredentials = LeaderCredentials -> [ShelleyLeaderCredentials StandardCrypto]
Creds.shelleyLeaderCredentials LeaderCredentials
leaderCredentials
      }
    CardanoHardForkTriggers
triggers
    (NodeConfiguration -> TransitionConfig DijkstraEra
mkTransitionConfig NodeConfiguration
nc)
    CheckpointsMap (CardanoBlock StandardCrypto)
forall blk. CheckpointsMap blk
emptyCheckpointsMap
    -- db-analyser derives this from the configuration the same way, so that it
    -- can validate what we forge.
    (NodeConfiguration -> ProtVer
mkProtocolVersion NodeConfiguration
nc)

-- | Forge a ChainDB from a ready-made Cardano 'ProtocolInfo' and its block
-- forgers (as produced by 'initialize'). Constructing the protocol from a node
-- configuration is the caller's responsibility, keeping this function free of
-- any configuration machinery. In particular, the caller is also responsible
-- for having validated the genesis (see
-- 'Ouroboros.Consensus.Shelley.Node.validateGenesis').
synthesize ::
  ( TopLevelConfig (CardanoBlock StandardCrypto) ->
    GenTxs (CardanoBlock StandardCrypto)
  ) ->
  DBSynthesizerOptions ->
  -- | The same Shelley genesis the 'ProtocolInfo' was built from; only its
  -- epoch length is used, to interpret a 'ForgeLimitEpoch'.
  ShelleyGenesis ->
  -- | The directory of the ChainDB to forge into.
  FilePath ->
  CardanoProtocol ->
  IO ForgeResult
synthesize :: (TopLevelConfig (CardanoBlock StandardCrypto)
 -> GenTxs (CardanoBlock StandardCrypto))
-> DBSynthesizerOptions
-> ShelleyGenesis
-> [Char]
-> CardanoProtocol
-> IO ForgeResult
synthesize TopLevelConfig (CardanoBlock StandardCrypto)
-> GenTxs (CardanoBlock StandardCrypto)
genTxs DBSynthesizerOptions
confOptions ShelleyGenesis
shelleyGenesis [Char]
confDbDir (ProtocolInfo{TopLevelConfig (CardanoBlock StandardCrypto)
pInfoConfig :: TopLevelConfig (CardanoBlock StandardCrypto)
pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig, ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK
pInfoInitLedger :: ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK
pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b ValuesMK
pInfoInitLedger}, Tracer IO KESAgentClientTrace
-> IO [MkBlockForging IO (CardanoBlock StandardCrypto)]
mkForgers) =
  (ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult)
-> (ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
registry -> do
    snapshotDelayRng <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
    let
      epochSize = ShelleyGenesis -> EpochSize
sgEpochLength ShelleyGenesis
shelleyGenesis
      chunkInfo = StorageConfig (CardanoBlock StandardCrypto) -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
Node.nodeImmutableDbChunkInfo (TopLevelConfig (CardanoBlock StandardCrypto)
-> StorageConfig (CardanoBlock StandardCrypto)
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig (CardanoBlock StandardCrypto)
pInfoConfig)
      flavargs = SomeBackendArgs IO (CardanoBlock StandardCrypto)
-> LedgerDbBackendArgs IO (CardanoBlock StandardCrypto)
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV2 (SomeBackendArgs IO (CardanoBlock StandardCrypto)
 -> LedgerDbBackendArgs IO (CardanoBlock StandardCrypto))
-> SomeBackendArgs IO (CardanoBlock StandardCrypto)
-> LedgerDbBackendArgs IO (CardanoBlock StandardCrypto)
forall a b. (a -> b) -> a -> b
$ Args IO Mem -> SomeBackendArgs IO (CardanoBlock StandardCrypto)
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
SomeBackendArgs Args IO Mem
forall (m :: * -> *). Args m Mem
InMemArgs
      dbArgs =
        ResourceRegistry IO
-> TopLevelConfig (CardanoBlock StandardCrypto)
-> ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK
-> ChunkInfo
-> (CardanoBlock StandardCrypto -> Bool)
-> (RelativeMountPoint -> SomeHasFS IO)
-> (RelativeMountPoint -> SomeHasFS IO)
-> StdGen
-> LedgerDbBackendArgs IO (CardanoBlock StandardCrypto)
-> Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto)
-> Complete ChainDbArgs IO (CardanoBlock StandardCrypto)
forall blk (m :: * -> *).
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> StdGen
-> LedgerDbBackendArgs m blk
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
ChainDB.completeChainDbArgs
          ResourceRegistry IO
registry
          TopLevelConfig (CardanoBlock StandardCrypto)
pInfoConfig
          ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK
pInfoInitLedger
          ChunkInfo
chunkInfo
          (Bool -> CardanoBlock StandardCrypto -> Bool
forall a b. a -> b -> a
const Bool
True)
          ([Char] -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS [Char]
confDbDir)
          ([Char] -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS [Char]
confDbDir)
          StdGen
snapshotDelayRng
          LedgerDbBackendArgs IO (CardanoBlock StandardCrypto)
flavargs
          (Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto)
 -> Complete ChainDbArgs IO (CardanoBlock StandardCrypto))
-> Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto)
-> Complete ChainDbArgs IO (CardanoBlock StandardCrypto)
forall a b. (a -> b) -> a -> b
$ Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk,
 CanUpgradeLedgerTables LedgerState blk) =>
Incomplete ChainDbArgs m blk
ChainDB.defaultArgs

    -- The KES agent client only reports a failure to connect by tracing it, so
    -- without this an unreachable agent would just forge nothing.
    mbfs <- mkForgers $ (("--> KES agent: " <>) . show) >$< stdoutTracer
    allocatedForgers <-
      traverse
        (\MkBlockForging IO (CardanoBlock StandardCrypto)
mbf -> ResourceRegistry IO
-> (ResourceId
    -> IO (BlockForging IO (CardanoBlock StandardCrypto)))
-> (BlockForging IO (CardanoBlock StandardCrypto) -> IO ())
-> IO
     (ResourceKey IO, BlockForging IO (CardanoBlock StandardCrypto))
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate ResourceRegistry IO
registry (IO (BlockForging IO (CardanoBlock StandardCrypto))
-> ResourceId -> IO (BlockForging IO (CardanoBlock StandardCrypto))
forall a b. a -> b -> a
const (MkBlockForging IO (CardanoBlock StandardCrypto)
-> IO (BlockForging IO (CardanoBlock StandardCrypto))
forall (m :: * -> *) blk.
MkBlockForging m blk -> m (BlockForging m blk)
BlockForging.mkBlockForging MkBlockForging IO (CardanoBlock StandardCrypto)
mbf)) BlockForging IO (CardanoBlock StandardCrypto) -> IO ()
forall (m :: * -> *) blk. BlockForging m blk -> m ()
BlockForging.finalize)
        mbfs
    let forgers = (ResourceKey IO, BlockForging IO (CardanoBlock StandardCrypto))
-> BlockForging IO (CardanoBlock StandardCrypto)
forall a b. (a, b) -> b
snd ((ResourceKey IO, BlockForging IO (CardanoBlock StandardCrypto))
 -> BlockForging IO (CardanoBlock StandardCrypto))
-> [(ResourceKey IO,
     BlockForging IO (CardanoBlock StandardCrypto))]
-> [BlockForging IO (CardanoBlock StandardCrypto)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ResourceKey IO, BlockForging IO (CardanoBlock StandardCrypto))]
allocatedForgers
    let fCount = [BlockForging IO (CardanoBlock StandardCrypto)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockForging IO (CardanoBlock StandardCrypto)]
forgers
    putStrLn $ "--> forger count: " ++ show fCount
    r <-
      if fCount > 0
        then do
          putStrLn $ "--> opening ChainDB on file system with mode: " ++ show synthOpenMode
          preOpenChainDB synthOpenMode confDbDir
          let dbTracer = Tracer IO a
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
          ChainDB.withDB (ChainDB.updateTracer dbTracer dbArgs) $ \ChainDB IO (CardanoBlock StandardCrypto)
chainDB -> do
            slotNo <- do
              tip <- STM IO (Point (CardanoBlock StandardCrypto))
-> IO (Point (CardanoBlock StandardCrypto))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (ChainDB IO (CardanoBlock StandardCrypto)
-> STM IO (Point (CardanoBlock StandardCrypto))
forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
ChainDB.getTipPoint ChainDB IO (CardanoBlock StandardCrypto)
chainDB)
              pure $ case pointSlot tip of
                WithOrigin SlotNo
Origin -> SlotNo
0
                At SlotNo
s -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s

            putStrLn $ "--> starting at: " ++ show slotNo
            runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig $ genTxs pInfoConfig
        else do
          putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched"
          pure $ ForgeResult 0
    mapM_ (release . fst) allocatedForgers $> r
 where
  DBSynthesizerOptions
    { DBSynthesizerOpenMode
synthOpenMode :: DBSynthesizerOpenMode
synthOpenMode :: DBSynthesizerOptions -> DBSynthesizerOpenMode
synthOpenMode
    , ForgeLimit
synthLimit :: ForgeLimit
synthLimit :: DBSynthesizerOptions -> ForgeLimit
synthLimit
    } = DBSynthesizerOptions
confOptions

preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO ()
preOpenChainDB :: DBSynthesizerOpenMode -> [Char] -> IO ()
preOpenChainDB DBSynthesizerOpenMode
mode [Char]
db =
  [Char] -> IO Bool
doesDirectoryExist [Char]
db IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> IO () -> Bool -> IO ()
forall a. a -> a -> Bool -> a
bool IO ()
create IO ()
checkMode
 where
  checkIsDB :: [[Char]] -> Bool
checkIsDB [[Char]]
ls = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList [[Char]]
ls Set [Char] -> Set [Char] -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set [Char]
chainDBDirs
  chainDBDirs :: Set [Char]
chainDBDirs = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList [[Char]
"immutable", [Char]
"ledger", [Char]
"volatile", [Char]
"gsm"]
  loc :: [Char]
loc = [Char]
"preOpenChainDB: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
db [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
  create :: IO ()
create = Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
db
  checkMode :: IO ()
checkMode = do
    isChainDB <- [[Char]] -> Bool
checkIsDB ([[Char]] -> Bool) -> IO [[Char]] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
listSubdirectories [Char]
db
    case mode of
      DBSynthesizerOpenMode
OpenCreate ->
        [Char] -> IO ()
forall a. [Char] -> IO a
throwConfigError ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
loc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" already exists. Use -f to overwrite or -a to append."
      DBSynthesizerOpenMode
OpenAppend
        | Bool
isChainDB ->
            () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      DBSynthesizerOpenMode
OpenCreateForce
        | Bool
isChainDB ->
            [Char] -> IO ()
removePathForcibly [Char]
db IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
create
      DBSynthesizerOpenMode
_ ->
        [Char] -> IO ()
forall a. [Char] -> IO a
throwConfigError ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
loc
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is non-empty and does not look like a ChainDB"
              [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" (i.e. it contains directories other than"
              [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" 'immutable'/'ledger'/'volatile'/'gsm'). Aborting."

  listSubdirectories :: [Char] -> IO [[Char]]
listSubdirectories [Char]
path = ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
isDir ([[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [[Char]]
listDirectory [Char]
path
   where
    isDir :: [Char] -> IO Bool
isDir [Char]
p = [Char] -> IO Bool
doesDirectoryExist ([Char]
path [Char] -> [Char] -> [Char]
</> [Char]
p)