chore: set db path as config and restart server on thread crash ( PLT…

…-6401 )

dapps-certification-persistence/src/IOHK/Certification/Persistence.hs

@@ -1,9 +1,13 @@
-module IOHK.Certification.Persistence (module X) where
-import IOHK.Certification.Persistence.Structure.Run as X 
+module IOHK.Certification.Persistence
+  ( module X
+  , MonadSelda
+  ) where
+import Database.Selda
+import IOHK.Certification.Persistence.Structure.Run as X
   ( Run(..)
   , Status(..)
   )
-import IOHK.Certification.Persistence.Structure.Certification as X 
+import IOHK.Certification.Persistence.Structure.Certification as X
   ( Certification(..)
   , L1Certification(..)
   , CertificationLevel(..)
@@ -46,7 +50,7 @@ import IOHK.Certification.Persistence.API as X
   , getRun
   , updateFinishedRun
   , getRuns
-  , withDb
+  , withSQLite'
   , getProfileId
   , getProfileAddress
   , syncRun

dapps-certification-persistence/src/IOHK/Certification/Persistence/API.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE OverloadedRecordDot   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
 
 module IOHK.Certification.Persistence.API where
 
@@ -515,6 +516,6 @@ getAllTiers = do
       , tierDtoTier = Tier{..}
       }
 
---TODO: replace this with a proper configuration
-withDb :: (MonadIO m, MonadMask m) => SeldaT SQLite m a -> m a
-withDb = withSQLite "certification.sqlite"
+-- | Polimorphic function to run a Selda computation with a SQLite database.
+withSQLite' :: (MonadIO m, MonadMask m) => FilePath -> (forall n. (MonadSelda n,MonadMask n) => n a) -> m a
+withSQLite' = withSQLite

nix/docker-files/docker.nix

@@ -1,7 +1,7 @@
 { inputs', pkgs, l, ... }: let
     imgAttributes = {
       name = "plutus-certification";
-      tag = "11";
+      tag = "12";
     };
     nixConfig = ''
         trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
@@ -13,7 +13,7 @@
         filter-syscalls = false
     '';
     entryPoint =
-      let addParameter = paramName: varName: '' 
+      let addParameter = paramName: varName: ''
           if [ -n "${"$"}${varName}" ]; then
             args="$args --${paramName} ${"$"}${varName}"
           fi
@@ -30,6 +30,7 @@
         ${addParameter "signature-timeout" "SIGNATURE_TIMEOUT"}
         ${addParameter "use-whitelist" "USE_WHITELIST"}
         ${addParameter "port" "PORT"}
+        ${addParameter "db-path" "DB_PATH"}
         if [ -n "$JWT_SECRET" ];
         then
             args="$args --jwt-secret $JWT_SECRET"
@@ -46,11 +47,12 @@
 
         # create a temporary directory for executing flakes
         mkdir -p /tmp
+        mkdir -p /db
 
         # copy the certificate bundle to the right place
         mkdir -p /etc/ssl/certs
         script="cp ${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt /etc/ssl/certs/ca-certificates.crt"
-        
+
         #TODO: change this --unsafe-bypass-subscription-validation
         args="$args --unsafe-bypass-subscription-validation"
 
@@ -61,7 +63,7 @@
         echo $script >&2
         eval "$script"
       '').outPath;
-  
+
     nixImage = pkgs.dockerTools.pullImage {
       imageName = "nixos/nix";
       imageDigest = "sha256:31b808456afccc2a419507ea112e152cf27e9bd2527517b0b6ca8639cc423501";
@@ -98,14 +100,14 @@
           ${pkgs.docker}/bin/docker load -i ${image}
       '').outPath;
     };
-in 
+in
 rec {
   inherit loadDockerImage;
 
-  runDockerImage = 
-    let addEnvVar = varName: '' 
+  runDockerImage =
+    let addEnvVar = varName: ''
         if [ -n "${"$"}${varName}" ]; then
-          docker_args="$docker_args -e ${varName}=${"$"}${varName}" 
+          docker_args="$docker_args -e ${varName}=${"$"}${varName}"
         fi
     '';
     in {
@@ -129,12 +131,13 @@ rec {
           ${addEnvVar "USE_WHITELIST"}
           ${addEnvVar "UNSAFE_PLAIN_ADDRESS_AUTH"}
           ${addEnvVar "PORT"}
+          ${addEnvVar "DB_PATH"}
 
           if [[ -z "$PORT" ]]; then
             export PORT=9671
           fi
           docker_args="$docker_args -p $PORT:$PORT"
-          
+
           script="docker run --rm $docker_args ${imgAttributes.name}:${imgAttributes.tag}"
           echo $script >&2
           eval "$script"
@@ -143,7 +146,7 @@ rec {
 
     pushDockerImage = {
       type = "app";
-      # Usage: run .\#dockerApps.pushDockerImage -- <docker registry> 
+      # Usage: run .\#dockerApps.pushDockerImage -- <docker registry>
       # Example: .\#dockerApps.pushDockerImage -- ghcr.io/demoiog
       program = (pkgs.writeShellScript "pushDockerImage" ''
           set -eEuo pipefail

nix/docker-files/run.sh

@@ -5,5 +5,6 @@
  WALLET_URL="http://192.168.2.128:8090" \
  WALLET_CERTIFICATION_PRICE=1000000 \
  JWT_SECRET2=secret \
+ DB_PATH=./db/certification2.sqlite \
  PORT=80 \
  nix run .#dockerApps.runDockerImage

server/Main.hs

@@ -68,8 +68,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Text as Text
 import System.Environment (lookupEnv)
 import Crypto.Random
-
-
+import Control.Monad.Reader (ReaderT(runReaderT))
 
 data Backend
   = Local
@@ -85,6 +84,7 @@ data Args = Args
   , useWhitelist :: !Bool
   , github :: !GitHubArgs
   , bypassSubscriptionValidation :: !Bool
+  , dbPath :: !FilePath
   }
 
 data GitHubArgs = GitHubArgs
@@ -152,6 +152,13 @@ argsParser =  Args
       ( long "unsafe-bypass-subscription-validation"
      <> help "Bypass subscription validation"
       )
+  <*> option str
+      ( long "db-path"
+     <> metavar "DB_PATH"
+     <> help "the path to the database. If not specified, \"./certification.sqlite\" is used"
+     <> showDefault
+     <> Opts.value "./certification.sqlite"
+      )
 
 data AuthMode = JWTAuth JWTArgs | PlainAddressAuth
 
@@ -303,16 +310,16 @@ renderRoot OnAuthMode =
 
 -- | plain address authentication
 -- NOTE: this is for testing only, and should not be used in production
-plainAddressAuthHandler :: Maybe Whitelist -> AuthHandler Request (DB.ProfileId,UserAddress)
-plainAddressAuthHandler whitelist = mkAuthHandler handler
+plainAddressAuthHandler :: WithDB -> Maybe Whitelist -> AuthHandler Request (DB.ProfileId,UserAddress)
+plainAddressAuthHandler withDb whitelist = mkAuthHandler handler
   where
   handler :: (MonadError ServerError m,MonadIO m,MonadMask m)
           => Request
           -> m (DB.ProfileId, UserAddress)
   handler req = do
      bs <- either throw401 pure $ extractAddress req
      verifyWhiteList whitelist (decodeUtf8 bs)
-     ensureProfile bs
+     runReaderT (ensureProfile bs) (WithDBWrapper withDb)
   maybeToEither e = maybe (Left e) Right
   extractAddress = maybeToEither "Missing Authorization header" . lookup "Authorization" . requestHeaders
 
@@ -358,17 +365,18 @@ whitelisted = do
 throw401 :: MonadError ServerError m => LBS.ByteString -> m a
 throw401 msg = throwError $ err401 { errBody = msg }
 
-genAuthServerContext :: Maybe Whitelist
+genAuthServerContext :: WithDB
+                     -> Maybe Whitelist
                      -> Maybe JWTConfig
                      -> Context (AuthHandler Request (DB.ProfileId,UserAddress) ': '[])
-genAuthServerContext whitelist mSecret = (case mSecret of
-  Nothing -> plainAddressAuthHandler whitelist
+genAuthServerContext withDb whitelist mSecret = (case mSecret of
+  Nothing -> plainAddressAuthHandler withDb whitelist
   Just JWTConfig{..} -> jwtAuthHandler whitelist jwtSecret ) :. EmptyContext
 
 -- TODO: replace the try with some versioning mechanism
-initDb :: IO ()
-initDb = void $ try' $
-  DB.withDb do
+initDb :: WithDB -> IO ()
+initDb withDb = void $ try' $
+  withDb do
     DB.createTables
     DB.addInitialData
 
@@ -422,41 +430,41 @@ main = do
       -- get the whitelisted addresses from $WLIST env var
       -- if useWhitelist is set to false the whitelist is ignored
       whitelist <- if not args.useWhitelist then pure Nothing else Just <$> whitelisted
-      _ <- initDb
-      jwtConfig <- getJwtArgs eb (args.auth)
-      adaPriceRef <- startSynchronizer eb args
+      _ <- initDb $ withDb' (args.dbPath)
+      jwtConfig <- getJwtArgs eb args
+      adaPriceRef <- startSynchronizer eb scheduleCrash args
       -- TODO: this has to be refactored
       runSettings settings . application (narrowEventBackend InjectServeRequest eb) $
         cors (const $ Just corsPolicy) .
-        serveWithContext (Proxy @APIWithSwagger) (genAuthServerContext whitelist jwtConfig) .
+        serveWithContext (Proxy @APIWithSwagger) (genAuthServerContext (withDb' (args.dbPath)) whitelist jwtConfig) .
         (\r -> swaggerSchemaUIServer (documentation args.auth)
                :<|> server (serverArgs args caps r eb whitelist adaPriceRef jwtConfig))
   exitFailure
   where
-  getJwtArgs eb authMode = withEvent eb OnAuthMode \ev ->
-    case authMode of
+  getJwtArgs eb args = withEvent eb OnAuthMode \ev ->
+    case (args.auth) of
       JWTAuth (JWTArgs mode expiration) -> Just <$> do
         secret <- case mode of
             JWTSecret secret -> do
               addField ev OnAuthModeFieldJWTSecret
               pure secret
             JWTGenerate -> do
               addField ev OnAuthModeFieldJWTGenerate
-              getJWTSecretFromDB
+              getJWTSecretFromDB args
         pure $ JWTConfig secret expiration
       _ -> do
         addField ev OnAuthModeFieldPlainAddressAuth
         pure Nothing
 
-  getJWTSecretFromDB :: IO String
-  getJWTSecretFromDB = do
+  getJWTSecretFromDB :: Args -> IO String
+  getJWTSecretFromDB args = do
     -- check if the secret is already in the db
-    maybeSecret <- DB.withDb do DB.getJWTSecret
+    maybeSecret <- withDb' args.dbPath DB.getJWTSecret
     case maybeSecret of
       -- if not generate a new one and store it in the db
       Nothing -> do
         secret <- generateSecret
-        DB.withDb do DB.insertJWTSecret (Text.pack secret)
+        withDb' args.dbPath  (DB.insertJWTSecret (Text.pack secret))
         pure secret
       -- if yes return it
       Just secret -> pure (Text.unpack secret)
@@ -469,9 +477,11 @@ main = do
       pure randomText
 
 
-  startSynchronizer eb args = do
+  startSynchronizer eb scheduleCrash args = do
     ref <- newIORef Nothing
-    _ <- forkIO $ startTransactionsMonitor (narrowEventBackend InjectSynchronizer eb) (args.wallet) ref 10
+    _ <- forkIO $ startTransactionsMonitor
+            (narrowEventBackend InjectSynchronizer eb) scheduleCrash
+            (args.wallet) ref 10 (WithDBWrapper (withDb' (args.dbPath)) )
     pure ref
   serverArgs args caps r eb whitelist ref jwtConfig = ServerArgs
     { serverCaps = caps
@@ -484,7 +494,10 @@ main = do
     , validateSubscriptions = not args.bypassSubscriptionValidation
     , serverGitHubCredentials = args.github.credentials
     , adaUsdPrice = liftIO $ readIORef ref
+    , withDb = withDb' (args.dbPath)
     }
+  withDb' :: (MonadIO m, MonadMask m) => FilePath -> (forall n. (DB.MonadSelda n,MonadMask n) => n a) -> m a
+  withDb' = DB.withSQLite'
   documentation PlainAddressAuth = swaggerJson
   documentation (JWTAuth _) = swaggerJsonWithLogin
 

src/Plutus/Certification/API.hs

@@ -3,6 +3,11 @@ module Plutus.Certification.API
   , Cicero.Run.RunLog(..)
   ) where
 
+import Plutus.Certification.Internal as X
+  ( WithDBWrapper(..)
+  , WithDB
+  , HasDb(..)
+  )
 import qualified IOHK.Cicero.API.Run as Cicero.Run (RunLog(..))
 
 import Plutus.Certification.API.Routes as X

src/Plutus/Certification/Internal.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes        #-}
 {-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingVia                #-}
@@ -18,6 +19,10 @@ import           GHC.Generics
 import           Data.Proxy
 import           GHC.TypeLits
 import           Data.Text as Text
+import           Control.Monad.Catch (MonadMask)
+
+import qualified IOHK.Certification.Persistence as DB
+import Control.Monad.RWS
 
 newtype JSONCustomOptions n a = JSONCustomOptions a deriving Generic
 
@@ -48,3 +53,18 @@ splitString maxChars = toValue . chunksOf maxChars
 split64 :: Text -> Value
 split64 = splitString 64
 
+type WithDB = forall a m. (MonadIO m, MonadMask m) => (forall n. (DB.MonadSelda n,MonadMask n) => n a) -> m a
+
+newtype WithDBWrapper = WithDBWrapper WithDB
+
+class HasDb env where
+  getWithDb :: env -> WithDB
+
+instance HasDb WithDBWrapper where
+  getWithDb (WithDBWrapper db') = db'
+
+withDb :: (MonadReader env m,HasDb env, MonadIO m,MonadMask m) => (forall n. (DB.MonadSelda n,MonadMask n) => n a) -> m a
+withDb dbAction = do
+  env <- ask
+  getWithDb env dbAction
+