{-# 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)