Improve stub server

1. expose a cli option to start the stub server in test-mode 2. add an endpoint to insert pool metadata manually in test-mode
input-output-hk · Oct 23, 2020 · 09ed767 · 09ed767
1 parent 85b3a1e
commit 09ed767
Show file tree

Hide file tree

Showing 5 changed files with 70 additions and 27 deletions.
diff --git a/app/Main.hs b/app/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP                 #-}
+
 module Main where
 
 import           Cardano.Prelude
@@ -19,6 +21,8 @@ import           Data.Monoid           ((<>))
 
 import           Options.Applicative   (Parser, ParserInfo, ParserPrefs)
 import qualified Options.Applicative   as Opt
+import qualified Data.ByteString.Lazy        as BL
+import           Data.Aeson                  (eitherDecode')
 
 
 main :: IO ()
@@ -40,6 +44,9 @@ data Command
   = CreateMigration SmashMigrationDir
   | RunMigrations SmashMigrationDir (Maybe SmashLogFileDir)
   | RunApplication
+#ifdef TESTING_MODE
+  | RunStubApplication
+#endif
   | RunApplicationWithDbSync SmashDbSyncNodeParams
   | InsertPool FilePath PoolId PoolMetadataHash
   | ReserveTickerName Text PoolMetadataHash
@@ -50,13 +57,20 @@ runCommand cmd =
     CreateMigration mdir -> doCreateMigration mdir
     RunMigrations mdir mldir -> runMigrations (\pgConfig -> pgConfig) False mdir mldir
     RunApplication -> runApp defaultConfiguration
+#ifdef TESTING_MODE
+    RunStubApplication -> runAppStubbed defaultConfiguration
+#endif
     RunApplicationWithDbSync dbSyncNodeParams ->
         race_
             (runDbSyncNode poolMetadataDbSyncNodePlugin dbSyncNodeParams)
             (runApp defaultConfiguration)
     InsertPool poolMetadataJsonPath poolId poolHash -> do
         putTextLn "Inserting pool metadata!"
-        result <- runPoolInsertion poolMetadataJsonPath poolId poolHash
+        poolMetadataJson <- readFile poolMetadataJsonPath
+        decodedMetadata <-  case (eitherDecode' $ BL.fromStrict (encodeUtf8 poolMetadataJson)) of
+                                Left err     -> panic $ toS err
+                                Right result -> return result
+        result <- runPoolInsertion postgresqlDataLayer decodedMetadata poolId poolHash
         either
             (\err -> putTextLn $ "Error occured. " <> renderLookupFail err)
             (\_ -> putTextLn "Insertion completed!")
@@ -144,6 +158,12 @@ pCommand =
         ( Opt.info pRunApp
           $ Opt.progDesc "Run the application that just serves the pool info."
           )
+#ifdef TESTING_MODE
+    <> Opt.command "run-stub-app"
+        ( Opt.info pRunStubApp
+          $ Opt.progDesc "Run the stub application that just serves the pool info."
+          )
+#endif
     <> Opt.command "run-app-with-db-sync"
         ( Opt.info pRunAppWithDbSync
           $ Opt.progDesc "Run the application that syncs up the pool info and serves it."
@@ -171,6 +191,12 @@ pCommand =
     pRunApp =
       pure RunApplication
 
+#ifdef TESTING_MODE
+    pRunStubApp :: Parser Command
+    pRunStubApp =
+      pure RunStubApplication
+#endif
+
     -- Empty right now but we might add some params over time. Like ports and stuff?
     pRunAppWithDbSync :: Parser Command
     pRunAppWithDbSync =

diff --git a/doc/getting-started/how-to-run-smash.md b/doc/getting-started/how-to-run-smash.md
@@ -121,3 +121,15 @@ Or if you have Basic Auth enabled (replace with you username/pass you have in yo
 curl -u ksaric:cirask -X PATCH -v http://localhost:3100/api/v1/delist -H 'content-type: application/json' -d '{"poolId": "062693863e0bcf9f619238f020741381d4d3748aae6faf1c012e80e7"}'
 ```
 
+## Running stub server for local testing purposes
+
+Make sure to build SMASH in testing mode:
+
+```
+stack install --flag 'smash:testing-mode'
+smash-exe run-stub-app
+curl -X POST -v -H 'content-type: application/json' -d @test_pool.json http://localhost:3100/api/
+v1/add/062693863e0bcf9f619238f020741381d4d3748aae6faf1c012e80e7/cbdfc4f21feb0a414b2b9471fa56b0ebd312825e63db776d68cc3fa0ca1f5a2f
+curl -X GET -v http://localhost:3100/api/v1/metadata/062693863e0bcf9f619238f020741381d4d3748aae6f
+af1c012e80e7/cbdfc4f21feb0a414b2b9471fa56b0ebd312825e63db776d68cc3fa0ca1f5a2f
+```
diff --git a/smash.cabal b/smash.cabal
@@ -148,6 +148,8 @@ executable smash-exe
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , aeson
+    , bytestring
     , cardano-prelude
     , smash
     , cardano-db-sync
@@ -157,6 +159,9 @@ executable smash-exe
   default-extensions:  NoImplicitPrelude
                        OverloadedStrings
 
+  if flag(testing-mode)
+    cpp-options:       -DTESTING_MODE
+
   ghc-options:         -Wall
                        -Wcompat
                        -Wincomplete-record-updates

diff --git a/src/DB.hs b/src/DB.hs
@@ -52,6 +52,7 @@ import           Cardano.Db.Schema            as X (AdminUser (..), Block (..),
                                                     RetiredPool (..),
                                                     poolMetadataMetadata)
 import qualified Cardano.Db.Types             as Types
+import qualified Prelude as Prelude
 
 -- | This is the data layer for the DB.
 -- The resulting operation has to be @IO@, it can be made more granular,
@@ -85,24 +86,26 @@ data DataLayer = DataLayer
 -- We do need state here. _This is thread safe._
 -- __This is really our model here.__
 stubbedDataLayer
-    :: IORef (Map (PoolId, PoolMetadataHash) Text)
+    :: IORef (Map (PoolId, PoolMetadataHash) (Text, Text))
     -> IORef [PoolId]
     -> DataLayer
 stubbedDataLayer ioDataMap ioDelistedPool = DataLayer
     { dlGetPoolMetadata     = \poolId poolmdHash -> do
         ioDataMap' <- readIORef ioDataMap
         case (Map.lookup (poolId, poolmdHash) ioDataMap') of
-            Just poolOfflineMetadata'   -> return . Right $ ("Test", poolOfflineMetadata')
+            Just (poolTicker', poolOfflineMetadata')
+              -> return . Right $ (poolTicker', poolOfflineMetadata')
             Nothing                     -> return $ Left (DbLookupPoolMetadataHash poolId poolmdHash)
     , dlAddPoolMetadata     = \ _ poolId poolmdHash poolMetadata poolTicker -> do
         -- TODO(KS): What if the pool metadata already exists?
-        _ <- modifyIORef ioDataMap (Map.insert (poolId, poolmdHash) poolMetadata)
+        _ <- modifyIORef ioDataMap (Map.insert (poolId, poolmdHash)
+          (poolMetadata, getPoolTicker poolTicker))
         return . Right $ poolMetadata
 
     , dlAddMetaDataReference = \poolId poolUrl poolMetadataHash -> panic "!"
 
     , dlAddReservedTicker = \tickerName poolMetadataHash -> panic "!"
-    , dlCheckReservedTicker = \tickerName -> panic "!"
+    , dlCheckReservedTicker = \tickerName -> pure Nothing
 
     , dlGetDelistedPools = readIORef ioDelistedPool
     , dlCheckDelistedPool = \poolId -> do
@@ -125,9 +128,9 @@ stubbedDataLayer ioDataMap ioDelistedPool = DataLayer
     }
 
 -- The approximation for the table.
-stubbedInitialDataMap :: Map (PoolId, PoolMetadataHash) Text
+stubbedInitialDataMap :: Map (PoolId, PoolMetadataHash) (Text, Text)
 stubbedInitialDataMap = Map.fromList
-    [ ((PoolId "AAAAC3NzaC1lZDI1NTE5AAAAIKFx4CnxqX9mCaUeqp/4EI1+Ly9SfL23/Uxd0Ieegspc", PoolMetadataHash "HASH"), show examplePoolOfflineMetadata)
+    [ ((PoolId "AAAAC3NzaC1lZDI1NTE5AAAAIKFx4CnxqX9mCaUeqp/4EI1+Ly9SfL23/Uxd0Ieegspc", PoolMetadataHash "HASH"), ("Test", show examplePoolOfflineMetadata))
     ]
 
 -- The approximation for the table.

diff --git a/src/Lib.hs b/src/Lib.hs
@@ -18,7 +18,7 @@ module Lib
 
 import           Cardano.Prelude             hiding (Handler)
 
-import           Data.Aeson                  (eitherDecode')
+import           Data.Aeson                  (eitherDecode', encode)
 import qualified Data.ByteString.Lazy        as BL
 import           Data.IORef                  (newIORef)
 import           Data.Swagger                (Info (..), Swagger (..))
@@ -35,7 +35,8 @@ import           Servant                     (Application, BasicAuth,
                                               BasicAuthData (..),
                                               BasicAuthResult (..), Capture,
                                               Context (..), Get, Handler (..),
-                                              Header, Headers, JSON, Patch,
+                                              Header, Headers, JSON, Patch, Post,
+                                              NoContent(..),
                                               QueryParam, ReqBody, Server,
                                               err403, err404, serveWithContext)
 import           Servant.API.ResponseHeaders (addHeader)
@@ -46,6 +47,8 @@ import           Types
 
 import           Paths_smash                 (version)
 
+import qualified Data.Text.Encoding as E
+
 
 -- |For api versioning.
 type APIVersion = "v1"
@@ -92,8 +95,10 @@ type SmashAPI =  OfflineMetadataAPI
             :<|> RetiredPoolsAPI
 #ifdef TESTING_MODE
             :<|> RetirePoolAPI
+            :<|> AddPoolAPI
 
 type RetirePoolAPI = "api" :> APIVersion :> "retired" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
+type AddPoolAPI = "api" :> APIVersion :> "add" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> ReqBody '[JSON] PoolOfflineMetadata :> ApiRes Post PoolId
 #endif
 
 
@@ -186,24 +191,11 @@ mkApp configuration = do
     convertToAppUsers (AdminUser username password) = ApplicationUser username password
 
 --runPoolInsertion poolMetadataJsonPath poolHash
-runPoolInsertion :: FilePath -> PoolId -> PoolMetadataHash -> IO (Either DBFail Text)
-runPoolInsertion poolMetadataJsonPath poolId poolHash = do
-    putTextLn $ "Inserting pool! " <> (toS poolMetadataJsonPath) <> " " <> (show poolId)
-
-    let dataLayer :: DataLayer
-        dataLayer = postgresqlDataLayer
-
-    --PoolHash -> ByteString -> IO (Either DBFail PoolHash)
-    poolMetadataJson <- readFile poolMetadataJsonPath
-
-    -- Let us try to decode the contents to JSON.
-    decodedMetadata <-  case (eitherDecode' $ BL.fromStrict (encodeUtf8 poolMetadataJson)) of
-                            Left err     -> panic $ toS err
-                            Right result -> return result
-
-    let addPoolMetadata = dlAddPoolMetadata dataLayer
-
-    addPoolMetadata Nothing poolId poolHash poolMetadataJson (pomTicker decodedMetadata)
+runPoolInsertion :: DataLayer -> PoolOfflineMetadata -> PoolId -> PoolMetadataHash -> IO (Either DBFail Text)
+runPoolInsertion dataLayer poolMetadata poolId poolHash = do
+    putTextLn $ "Inserting pool! " <> (show poolId)
+    dlAddPoolMetadata dataLayer Nothing poolId poolHash (E.decodeUtf8 . BL.toStrict . encode $ poolMetadata)
+      (pomTicker poolMetadata)
 
 runTickerNameInsertion :: Text -> PoolMetadataHash -> IO (Either DBFail ReservedTickerId)
 runTickerNameInsertion tickerName poolMetadataHash = do
@@ -256,6 +248,7 @@ server configuration dataLayer
     :<|>    getRetiredPools dataLayer
 #ifdef TESTING_MODE
     :<|>    retirePool dataLayer
+    :<|>    addPool dataLayer
 #endif
 
 
@@ -391,6 +384,10 @@ retirePool dataLayer poolId = convertIOToHandler $ do
     retiredPoolId <- addRetiredPool poolId
 
     return . ApiResult $ retiredPoolId
+
+addPool :: DataLayer -> PoolId -> PoolMetadataHash -> PoolOfflineMetadata -> Handler (ApiResult DBFail PoolId)
+addPool dataLayer poolId poolHash poolMetadata = fmap ApiResult $ convertIOToHandler $
+  (fmap . second) (const poolId) $ runPoolInsertion dataLayer poolMetadata poolId poolHash
 #endif
 
 -- For now, we just ignore the @BasicAuth@ definition.