FFI library

Author: jasagredo

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -15,30 +15,21 @@ import Cardano.Crypto.Init (cryptoInit)
 import Cardano.Tools.DBAnalyser.Block.Cardano (configFile)
 import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo)
 import Control.Concurrent
-import Control.Exception
 import Control.Monad (forever, void)
 import Control.Monad.Except
 import DBAnalyser.Parsers
-import qualified Data.Aeson as Aeson
 import qualified Data.List as L
-import qualified Data.Text as Text
-import qualified Debug.Trace as Debug
-import GHC.TypeLits (Symbol)
 import Main.Utf8
 import Options.Applicative
 import Options.Applicative.Help (Doc, line)
 import Ouroboros.Consensus.Cardano.SnapshotConversion
+import Ouroboros.Consensus.Config
+import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
 import System.Exit
 import System.FSNotify
 import System.FilePath
 
--- | FilePaths annotated with the purpose
-newtype FilePath' (s :: Symbol) = FP {rawFilePath :: FilePath}
-
-instance Show (FilePath' s) where
-  show = rawFilePath
-
 data Config
   = -- | Run in daemon mode, with an output directory
     DaemonConfig (FilePath' "OutDir")
@@ -49,19 +40,11 @@ data Config
       -- | Which format the output snapshot must be in
       Format
 
--- | Information inferred from the config file
-data FromConfigFile
-  = FromConfigFile
-      -- | The input format once supplied with a particular snapshot
-      (FilePath' "Snapshot" -> Format)
-      -- | The directory of snapshots, to be watched by inotify
-      (FilePath' "Snapshots")
-
 main :: IO ()
 main = withStdTerminalHandles $ do
   cryptoInit
   (conf, args) <- getCommandLineConfig
-  pInfo <- mkProtocolInfo args
+  pInfo <- configCodec . pInfoConfig <$> mkProtocolInfo args
   FromConfigFile inFormat ledgerDbPath <- getFormatFromConfig (FP $ configFile args)
   case conf of
     NoDaemonConfig f t -> do
@@ -219,115 +202,3 @@ parsePath optName strHelp =
         , metavar "PATH"
         ]
     )
-
-{-------------------------------------------------------------------------------
-  Parsing the configuration file
--------------------------------------------------------------------------------}
-
-instance Aeson.FromJSON FromConfigFile where
-  parseJSON = Aeson.withObject "CardanoConfigFile" $ \o -> do
-    DBPaths imm vol <- Aeson.parseJSON (Aeson.Object o)
-    inFmt <- ($ vol) <$> Aeson.parseJSON (Aeson.Object o)
-    pure $ FromConfigFile inFmt imm
-
-data DBPaths = DBPaths (FilePath' "Snapshots") (FilePath' "Volatile")
-
--- | Possible database locations:
---
---  (1) Provided as flag: we would need to receive that same flag. For simplicity we will ban this scenario for now, requiring users to put the path in the config file.
---
---  (2) Not provided: we default to "mainnet"
---
---  (3) Provided in the config file:
---
---    (1) One database path: we use that one
---
---        @@
---        "DatabasePath": "some/path"
---        @@
---
---    (2) Multiple databases paths: we use the immutable one
---
---        @@
---        "DatabasePath": {
---          "ImmutableDbPath": "some/path",
---          "VolatileDbPath": "some/other/path",
---        }
---        @@
-instance Aeson.FromJSON DBPaths where
-  parseJSON = Aeson.withObject "CardanoConfigFile" $ \o -> do
-    pncDatabase <- o Aeson..:? "DatabasePath"
-    (imm, vol) <- case pncDatabase of
-      Nothing -> pure ("mainnet", "mainnet") -- (2)
-      Just p@(Aeson.Object{}) ->
-        Aeson.withObject
-          "NodeDatabasePaths"
-          (\o' -> (,) <$> o' Aeson..: "ImmutableDbPath" <*> o' Aeson..: "VolatileDbPath") -- (3.2)
-          p
-      Just (Aeson.String s) ->
-        let
-          s' = Text.unpack s
-         in
-          pure (s', s') -- (3.1)
-      _ -> fail "NodeDatabasePaths must be an object or a string"
-    pure $ DBPaths (FP $ imm </> "ledger") (FP vol)
-
--- | Possible formats
---
---  (1) Nothing provided: we use InMemory
---
---  (2) Provided in config file:
---
---    (1) "V2InMem": we use InMemory
---
---        @@
---        "LedgerDB": {
---          "Backend": "V2InMem"
---        }
---        @@
---
---    (2) "V1LMDB": we use LMDB
---
---        @@
---        "LedgerDB": {
---          "Backend": "V1LMDB"
---        }
---        @@
---
---    (3) "V2LSM"
---        LSM database locations:
---        (1) Nothing provided: we use "lsm" in the volatile directory
---
---        @@
---        "LedgerDB": {
---          "Backend": "V2LSM"
---        }
---        @@
---
---        (2) Provided in file: we use that one
---
---        @@
---        "LedgerDB": {
---          "Backend": "V2LSM",
---          "LSMDatabasePath": "some/path"
---        }
---        @@
-instance Aeson.FromJSON (FilePath' "Volatile" -> FilePath' "Snapshot" -> Format) where
-  parseJSON = Aeson.withObject "CardanoConfigFile" $ \o -> do
-    ldb <- Debug.traceShowId <$> o Aeson..:? "LedgerDB"
-    case ldb of
-      Nothing -> pure $ const $ Mem . rawFilePath -- (1)
-      Just ldb' -> do
-        bkd <- ldb' Aeson..:? "Backend"
-        case bkd :: Maybe String of
-          Just "V1LMDB" -> pure $ const $ LMDB . rawFilePath -- (2.2)
-          Just "V2LSM" -> do
-            mDbPath <- ldb' Aeson..:? "LSMDatabasePath"
-            case mDbPath of
-              Nothing -> pure $ \v -> flip LSM (rawFilePath v </> "lsm") . rawFilePath -- (2.3.1)
-              Just dbPath -> pure $ const $ flip LSM dbPath . rawFilePath -- (2.3.2)
-          _ -> pure $ const $ Mem . rawFilePath -- (2.1)
-
-getFormatFromConfig :: FilePath' "ConfigFile" -> IO FromConfigFile
-getFormatFromConfig (FP configPath) =
-  either (throwIO . userError) pure =<< Aeson.eitherDecodeFileStrict' configPath

ouroboros-consensus-cardano/external/Ouroboros/Consensus/Cardano/SnapshotConversion/External.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Ouroboros.Consensus.Cardano.SnapshotConversion.External () where
+
+import Cardano.Chain.Slotting
+import Control.Monad.Except
+import Data.SOP.Strict
+import Foreign.C.String
+import Ouroboros.Consensus.Byron.Ledger.Config
+import qualified Ouroboros.Consensus.Cardano.SnapshotConversion as Impl
+import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
+import Ouroboros.Consensus.HardFork.Combinator.Basics
+import Ouroboros.Consensus.Shelley.Ledger.Config
+import System.FilePath
+
+foreign export ccall ffiConvertSnapshot :: CString -> CString -> CString -> IO ()
+
+ffiConvertSnapshot :: CString -> CString -> CString -> IO ()
+ffiConvertSnapshot cfgFileC outDirC snapNameC = do
+  [cfgFile, outDir, snapName] <- mapM peekCString [cfgFileC, outDirC, snapNameC]
+  Impl.FromConfigFile inFmt lgrPath <- Impl.getFormatFromConfig $ Impl.FP cfgFile
+
+  res <-
+    runExceptT $
+      Impl.convertSnapshot
+        False
+        ( HardForkCodecConfig $
+            PerEraCodecConfig $
+              ByronCodecConfig (EpochSlots $ 2160 * 10)
+                :* ShelleyCodecConfig
+                :* ShelleyCodecConfig
+                :* ShelleyCodecConfig
+                :* ShelleyCodecConfig
+                :* ShelleyCodecConfig
+                :* ShelleyCodecConfig
+                :* ShelleyCodecConfig
+                :* Nil
+        )
+        (inFmt (Impl.FP @"Snapshot" $ Impl.rawFilePath lgrPath </> snapName))
+        (Impl.Mem $ outDir </> snapName)
+  case res of
+    Left err -> putStrLn $ show err
+    Right () -> pure ()

ouroboros-consensus-cardano/external/entry.c

@@ -0,0 +1,19 @@
+#include <stdlib.h>
+#include "HsFFI.h"
+
+HsBool mylib_init(void){
+  int argc = 1;
+  char *argv[] = { "snapshot-conversion", NULL };
+  char **pargv = argv;
+
+  // Initialize Haskell runtime
+  hs_init(&argc, &pargv);
+
+  // do any other initialization here and
+  // return false if there was a problem
+  return HS_BOOL_TRUE;
+}
+
+void mylib_end(void){
+  hs_exit();
+}

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -36,6 +36,28 @@ flag asserts
   manual: False
   default: False
 
+flag fat-foreign-dylib
+  description:
+    Enable foreign library compilation.
+    Notice this requires a GHC compiled with fPIC.
+
+    ```
+    git clone [email protected]:ghc/ghc
+    cd ghc
+    git submodule update --init --recursive
+    ./boot
+    CFLAGS=-fPIC ./configure
+    CFLAGS=-fPIC ./hadrian/build -j --docs=none binary-dist "*.*.ghc.hs.opts += -fPIC \
+                                                             *.*.ghc.c.opts += -fPIC \
+                                                             *.*.cc.c.opts += -fPIC"
+    ghcup install ghc -u "file:///.../ghc/_build/bindist/ghc-x.y.z-x86_64-unknown-linux.tar.xz" x.y.z-fpic
+    echo "package *\n  ghc-options: -fPIC" >> cabal.project.local
+    cabal build -w ghc-x.y.z-fpic -ffat-foreign-dylib ...
+    ```
+
+  manual: True
+  default: False
+
 common common-lib
   default-language: Haskell2010
   ghc-options:
@@ -185,9 +207,12 @@ library snapshot-conversion
   hs-source-dirs: src/snapshot-conversion
   other-modules:
     Ouroboros.Consensus.Cardano.StreamingLedgerTables
+
   exposed-modules:
     Ouroboros.Consensus.Cardano.SnapshotConversion
+
   build-depends:
+    aeson,
     ansi-terminal,
     base,
     cardano-ledger-binary,
@@ -211,6 +236,32 @@ library snapshot-conversion
     terminal-progress-bar,
     text,
 
+foreign-library snapshot-conversion-ffi
+  import: common-lib
+  type: native-shared
+  hs-source-dirs: external
+  c-sources:
+    external/entry.c
+    external/fini_array_shim.c
+
+  other-modules: Ouroboros.Consensus.Cardano.SnapshotConversion.External
+  ghc-options:
+    -static
+    -threaded
+    -fPIC
+
+  build-depends:
+    base,
+    cardano-ledger-byron,
+    filepath,
+    mtl,
+    ouroboros-consensus,
+    ouroboros-consensus-cardano,
+    snapshot-conversion,
+    strict-sop-core,
+
+  if !flag(fat-foreign-dylib)
+    buildable: False
 
 library unstable-byronspec
   import: common-lib
@@ -727,20 +778,17 @@ executable immdb-server
 executable snapshot-converter
   import: common-exe
   hs-source-dirs: app
-
   main-is: snapshot-converter.hs
   build-depends:
-    fsnotify,
     base,
     cardano-crypto-class,
+    filepath,
+    fsnotify,
     mtl,
     optparse-applicative,
     ouroboros-consensus,
-    ouroboros-consensus-cardano:{unstable-cardano-tools, ouroboros-consensus-cardano, snapshot-conversion},
-    text,
+    ouroboros-consensus-cardano:{ouroboros-consensus-cardano, snapshot-conversion, unstable-cardano-tools},
     with-utf8,
-    filepath,
-    aeson
 
   other-modules:
     DBAnalyser.Parsers