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

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

import Cardano.Api.Any (displayError)
import Cardano.Node.Protocol.Cardano (mkConsensusProtocolCardano)
import Cardano.Node.Types
import Cardano.Tools.DBSynthesizer.Forging
import Cardano.Tools.DBSynthesizer.Orphans ()
import Cardano.Tools.DBSynthesizer.Types
import Control.Monad (filterM)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Except.Extra
  ( firstExceptT
  , handleIOExceptT
  , hoistEither
  , runExceptT
  )
import Control.ResourceRegistry
import Control.Tracer
import Data.Aeson as Aeson
  ( FromJSON
  , Result (..)
  , Value
  , eitherDecodeFileStrict'
  , eitherDecodeStrict'
  , fromJSON
  )
import Data.Bool (bool)
import Data.ByteString as BS (ByteString, readFile)
import qualified Data.Set as Set
import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Cardano.Node
import Ouroboros.Consensus.Config (TopLevelConfig, configStorage)
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.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.V1.Args as LedgerDB.V1
import Ouroboros.Consensus.Util.IOLike (atomically)
import Ouroboros.Network.Block
import Ouroboros.Network.Point (WithOrigin (..))
import System.Directory
import System.FilePath (takeDirectory, (</>))

initialize ::
  NodeFilePaths ->
  NodeCredentials ->
  DBSynthesizerOptions ->
  IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto))
initialize :: NodeFilePaths
-> NodeCredentials
-> DBSynthesizerOptions
-> IO
     (Either
        String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto))
initialize NodeFilePaths{String
nfpConfig :: String
nfpConfig :: NodeFilePaths -> String
nfpConfig, String
nfpChainDB :: String
nfpChainDB :: NodeFilePaths -> String
nfpChainDB} NodeCredentials
creds DBSynthesizerOptions
synthOptions = do
  relativeToConfig :: (FilePath -> FilePath) <-
    String -> String -> String
(</>) (String -> String -> String)
-> (String -> String) -> String -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory (String -> String -> String) -> IO String -> IO (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute String
nfpConfig
  runExceptT $ do
    conf <- initConf relativeToConfig
    proto <- initProtocol relativeToConfig conf
    pure (conf, proto)
 where
  initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig
  initConf :: (String -> String) -> ExceptT String IO DBSynthesizerConfig
initConf String -> String
relativeToConfig = do
    inp <- (IOException -> String)
-> IO ByteString -> ExceptT String IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT IOException -> String
forall a. Show a => a -> String
show (String -> IO ByteString
BS.readFile String
nfpConfig)
    configStub <- adjustFilePaths relativeToConfig <$> readJson inp
    shelleyGenesis <- readFileJson $ ncsShelleyGenesisFile configStub
    _ <- hoistEither $ validateGenesis shelleyGenesis
    let
      protocolCredentials =
        ProtocolFilepaths
          { byronCertFile :: Maybe String
byronCertFile = Maybe String
forall a. Maybe a
Nothing
          , byronKeyFile :: Maybe String
byronKeyFile = Maybe String
forall a. Maybe a
Nothing
          , shelleyKESFile :: Maybe String
shelleyKESFile = NodeCredentials -> Maybe String
credKESFile NodeCredentials
creds
          , shelleyVRFFile :: Maybe String
shelleyVRFFile = NodeCredentials -> Maybe String
credVRFFile NodeCredentials
creds
          , shelleyCertFile :: Maybe String
shelleyCertFile = NodeCredentials -> Maybe String
credCertFile NodeCredentials
creds
          , shelleyBulkCredsFile :: Maybe String
shelleyBulkCredsFile = NodeCredentials -> Maybe String
credBulkFile NodeCredentials
creds
          }
    pure
      DBSynthesizerConfig
        { confConfigStub = configStub
        , confOptions = synthOptions
        , confProtocolCredentials = protocolCredentials
        , confShelleyGenesis = shelleyGenesis
        , confDbDir = nfpChainDB
        }

  initProtocol ::
    (FilePath -> FilePath) ->
    DBSynthesizerConfig ->
    ExceptT String IO (CardanoProtocolParams StandardCrypto)
  initProtocol :: (String -> String)
-> DBSynthesizerConfig
-> ExceptT String IO (CardanoProtocolParams StandardCrypto)
initProtocol String -> String
relativeToConfig DBSynthesizerConfig{NodeConfigStub
confConfigStub :: DBSynthesizerConfig -> NodeConfigStub
confConfigStub :: NodeConfigStub
confConfigStub, ProtocolFilepaths
confProtocolCredentials :: DBSynthesizerConfig -> ProtocolFilepaths
confProtocolCredentials :: ProtocolFilepaths
confProtocolCredentials} = do
    hfConfig :: NodeHardForkProtocolConfiguration <-
      Either String NodeHardForkProtocolConfiguration
-> ExceptT String IO NodeHardForkProtocolConfiguration
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither Either String NodeHardForkProtocolConfiguration
hfConfig_
    byronConfig :: NodeByronProtocolConfiguration <-
      adjustFilePaths relativeToConfig <$> hoistEither byConfig_

    firstExceptT displayError $
      mkConsensusProtocolCardano
        byronConfig
        shelleyConfig
        alonzoConfig
        conwayConfig
        hfConfig
        (Just confProtocolCredentials)
   where
    shelleyConfig :: NodeShelleyProtocolConfiguration
shelleyConfig = GenesisFile
-> Maybe GenesisHash -> NodeShelleyProtocolConfiguration
NodeShelleyProtocolConfiguration (String -> GenesisFile
GenesisFile (String -> GenesisFile) -> String -> GenesisFile
forall a b. (a -> b) -> a -> b
$ NodeConfigStub -> String
ncsShelleyGenesisFile NodeConfigStub
confConfigStub) Maybe GenesisHash
forall a. Maybe a
Nothing
    alonzoConfig :: NodeAlonzoProtocolConfiguration
alonzoConfig = GenesisFile -> Maybe GenesisHash -> NodeAlonzoProtocolConfiguration
NodeAlonzoProtocolConfiguration (String -> GenesisFile
GenesisFile (String -> GenesisFile) -> String -> GenesisFile
forall a b. (a -> b) -> a -> b
$ NodeConfigStub -> String
ncsAlonzoGenesisFile NodeConfigStub
confConfigStub) Maybe GenesisHash
forall a. Maybe a
Nothing
    conwayConfig :: NodeConwayProtocolConfiguration
conwayConfig = GenesisFile -> Maybe GenesisHash -> NodeConwayProtocolConfiguration
NodeConwayProtocolConfiguration (String -> GenesisFile
GenesisFile (String -> GenesisFile) -> String -> GenesisFile
forall a b. (a -> b) -> a -> b
$ NodeConfigStub -> String
ncsConwayGenesisFile NodeConfigStub
confConfigStub) Maybe GenesisHash
forall a. Maybe a
Nothing
    hfConfig_ :: Either String NodeHardForkProtocolConfiguration
hfConfig_ = Value -> Either String NodeHardForkProtocolConfiguration
forall a. FromJSON a => Value -> Either String a
eitherParseJson (Value -> Either String NodeHardForkProtocolConfiguration)
-> Value -> Either String NodeHardForkProtocolConfiguration
forall a b. (a -> b) -> a -> b
$ NodeConfigStub -> Value
ncsNodeConfig NodeConfigStub
confConfigStub
    byConfig_ :: Either String NodeByronProtocolConfiguration
byConfig_ = Value -> Either String NodeByronProtocolConfiguration
forall a. FromJSON a => Value -> Either String a
eitherParseJson (Value -> Either String NodeByronProtocolConfiguration)
-> Value -> Either String NodeByronProtocolConfiguration
forall a b. (a -> b) -> a -> b
$ NodeConfigStub -> Value
ncsNodeConfig NodeConfigStub
confConfigStub

readJson :: (Monad m, FromJSON a) => ByteString -> ExceptT String m a
readJson :: forall (m :: * -> *) a.
(Monad m, FromJSON a) =>
ByteString -> ExceptT String m a
readJson = Either String a -> ExceptT String m a
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either String a -> ExceptT String m a)
-> (ByteString -> Either String a)
-> ByteString
-> ExceptT String m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict'

readFileJson :: FromJSON a => FilePath -> ExceptT String IO a
readFileJson :: forall a. FromJSON a => String -> ExceptT String IO a
readFileJson String
f = (IOException -> String)
-> IO (Either String a) -> ExceptT String IO (Either String a)
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT IOException -> String
forall a. Show a => a -> String
show (String -> IO (Either String a)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' String
f) ExceptT String IO (Either String a)
-> (Either String a -> ExceptT String IO a) -> ExceptT String IO a
forall a b.
ExceptT String IO a
-> (a -> ExceptT String IO b) -> ExceptT String IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String a -> ExceptT String IO a
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither

eitherParseJson :: FromJSON a => Aeson.Value -> Either String a
eitherParseJson :: forall a. FromJSON a => Value -> Either String a
eitherParseJson Value
v = case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
  Error String
err -> String -> Either String a
forall a b. a -> Either a b
Left String
err
  Success a
a -> a -> Either String a
forall a b. b -> Either a b
Right a
a

synthesize ::
  ( TopLevelConfig (CardanoBlock StandardCrypto) ->
    GenTxs (CardanoBlock StandardCrypto) mk
  ) ->
  DBSynthesizerConfig ->
  (CardanoProtocolParams StandardCrypto) ->
  IO ForgeResult
synthesize :: forall mk.
(TopLevelConfig (CardanoBlock StandardCrypto)
 -> GenTxs (CardanoBlock StandardCrypto) mk)
-> DBSynthesizerConfig
-> CardanoProtocolParams StandardCrypto
-> IO ForgeResult
synthesize TopLevelConfig (CardanoBlock StandardCrypto)
-> GenTxs (CardanoBlock StandardCrypto) mk
genTxs DBSynthesizerConfig{DBSynthesizerOptions
confOptions :: DBSynthesizerConfig -> DBSynthesizerOptions
confOptions :: DBSynthesizerOptions
confOptions, ShelleyGenesis
confShelleyGenesis :: DBSynthesizerConfig -> ShelleyGenesis
confShelleyGenesis :: ShelleyGenesis
confShelleyGenesis, String
confDbDir :: DBSynthesizerConfig -> String
confDbDir :: String
confDbDir} CardanoProtocolParams StandardCrypto
runP =
  (ResourceRegistry IO -> IO ForgeResult) -> IO ForgeResult
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread 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
    let
      epochSize :: EpochSize
epochSize = ShelleyGenesis -> EpochSize
sgEpochLength ShelleyGenesis
confShelleyGenesis
      chunkInfo :: ChunkInfo
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)
      bss :: LedgerDbFlavorArgs f m
bss = FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m
forall (f :: * -> *) (m :: * -> *).
FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.V1.V1Args FlushFrequency
LedgerDB.V1.DisableFlushing BackingStoreArgs f m
forall (f :: * -> *) (m :: * -> *). BackingStoreArgs f m
InMemoryBackingStoreArgs
      flavargs :: LedgerDbFlavorArgs f m
flavargs = LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m
forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.LedgerDbFlavorArgsV1 LedgerDbFlavorArgs f m
forall {f :: * -> *} {m :: * -> *}. LedgerDbFlavorArgs f m
bss
      dbArgs :: Complete ChainDbArgs IO (CardanoBlock StandardCrypto)
dbArgs =
        ResourceRegistry IO
-> TopLevelConfig (CardanoBlock StandardCrypto)
-> ExtLedgerState (CardanoBlock StandardCrypto) ValuesMK
-> ChunkInfo
-> (CardanoBlock StandardCrypto -> Bool)
-> (RelativeMountPoint -> SomeHasFS IO)
-> (RelativeMountPoint -> SomeHasFS IO)
-> Complete LedgerDbFlavorArgs IO
-> Incomplete ChainDbArgs IO (CardanoBlock StandardCrypto)
-> Complete ChainDbArgs IO (CardanoBlock StandardCrypto)
forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> 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)
          (String -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS String
confDbDir)
          (String -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS String
confDbDir)
          Complete LedgerDbFlavorArgs IO
forall {f :: * -> *} {m :: * -> *}. LedgerDbFlavorArgs f m
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. Monad m => Incomplete ChainDbArgs m blk
ChainDB.defaultArgs

    forgers <- IO [BlockForging IO (CardanoBlock StandardCrypto)]
blockForging
    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
    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. Applicative 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
 where
  DBSynthesizerOptions
    { DBSynthesizerOpenMode
synthOpenMode :: DBSynthesizerOpenMode
synthOpenMode :: DBSynthesizerOptions -> DBSynthesizerOpenMode
synthOpenMode
    , ForgeLimit
synthLimit :: ForgeLimit
synthLimit :: DBSynthesizerOptions -> ForgeLimit
synthLimit
    } = DBSynthesizerOptions
confOptions
  ( 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
      }
    , IO [BlockForging IO (CardanoBlock StandardCrypto)]
blockForging
    ) = CardanoProtocolParams StandardCrypto
-> (ProtocolInfo (CardanoBlock StandardCrypto),
    IO [BlockForging IO (CardanoBlock StandardCrypto)])
forall c (m :: * -> *).
(IOLike m, CardanoHardForkConstraints c) =>
CardanoProtocolParams c
-> (ProtocolInfo (CardanoBlock c),
    m [BlockForging m (CardanoBlock c)])
protocolInfoCardano CardanoProtocolParams StandardCrypto
runP

preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO ()
preOpenChainDB :: DBSynthesizerOpenMode -> String -> IO ()
preOpenChainDB DBSynthesizerOpenMode
mode String
db =
  String -> IO Bool
doesDirectoryExist String
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 :: [String] -> Bool
checkIsDB [String]
ls = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
ls Set String -> Set String -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set String
chainDBDirs
  chainDBDirs :: Set String
chainDBDirs = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"immutable", String
"ledger", String
"volatile", String
"gsm"]
  loc :: String
loc = String
"preOpenChainDB: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
db String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
  create :: IO ()
create = Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
db
  checkMode :: IO ()
checkMode = do
    isChainDB <- [String] -> Bool
checkIsDB ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listSubdirectories String
db
    case mode of
      DBSynthesizerOpenMode
OpenCreate ->
        String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 ->
            String -> IO ()
removePathForcibly String
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
_ ->
        String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
loc
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is non-empty and does not look like a ChainDB"
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (i.e. it contains directories other than"
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 'immutable'/'ledger'/'volatile'/'gsm'). Aborting."

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