[CAD-1838] Add whitelisting (listing) to return delisted.

Author: ksaric

.gitignore

@@ -2,4 +2,5 @@
 dist-newstyle/
 *~
 tags
+stack.yaml.lock
 result*

schema/migration-2-0003-20201001.sql

@@ -0,0 +1,32 @@
+-- Persistent generated migration.
+
+CREATE FUNCTION migrate() RETURNS void AS $$
+DECLARE
+  next_version int ;
+BEGIN
+  SELECT stage_two + 1 INTO next_version FROM schema_version ;
+  IF next_version = 3 THEN
+    ALTER TABLE "pool_metadata_reference" ALTER COLUMN "pool_id" TYPE text;
+    ALTER TABLE "pool_metadata_reference" ALTER COLUMN "url" TYPE text;
+    ALTER TABLE "pool_metadata_reference" ALTER COLUMN "hash" TYPE text;
+    ALTER TABLE "pool_metadata" ALTER COLUMN "pool_id" TYPE text;
+    ALTER TABLE "pool_metadata" ALTER COLUMN "ticker_name" TYPE text;
+    ALTER TABLE "pool_metadata" ALTER COLUMN "hash" TYPE text;
+    ALTER TABLE "pool_metadata" ALTER COLUMN "metadata" TYPE text;
+    ALTER TABLE "pool_metadata_fetch_error" ALTER COLUMN "pool_id" TYPE text;
+    ALTER TABLE "pool_metadata_fetch_error" ALTER COLUMN "pool_hash" TYPE text;
+    ALTER TABLE "delisted_pool" ALTER COLUMN "pool_id" TYPE text;
+    ALTER TABLE "delisted_pool" ADD CONSTRAINT "unique_delisted_pool" UNIQUE("pool_id");
+    ALTER TABLE "delisted_pool" DROP CONSTRAINT "unique_blacklisted_pool";
+    ALTER TABLE "reserved_ticker" ALTER COLUMN "name" TYPE text;
+    ALTER TABLE "reserved_ticker" ALTER COLUMN "pool_hash" TYPE text;
+    -- Hand written SQL statements can be added here.
+    UPDATE schema_version SET stage_two = 3 ;
+    RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ;
+  END IF ;
+END ;
+$$ LANGUAGE plpgsql ;
+
+SELECT migrate() ;
+
+DROP FUNCTION migrate() ;

smash.cabal

@@ -50,6 +50,7 @@ library
     -- DB operations
     , Cardano.Db.Error
     , Cardano.Db.Insert
+    , Cardano.Db.Delete
     , Cardano.Db.Query
     , Cardano.Db.Types
 

src/Cardano/Db/Delete.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Cardano.Db.Delete
+  ( deleteDelistedPool
+  ) where
+
+import           Cardano.Prelude hiding (Meta)
+
+import           Control.Monad.IO.Class (MonadIO)
+import           Control.Monad.Trans.Reader (ReaderT)
+
+import           Database.Persist.Class (AtLeastOneUniqueKey, Key, PersistEntityBackend,
+                    getByValue, insert, checkUnique)
+import           Database.Persist.Sql (SqlBackend, (==.), deleteCascade, selectKeysList)
+import           Database.Persist.Types (entityKey)
+
+import           Cardano.Db.Schema
+import           Cardano.Db.Error
+import qualified Cardano.Db.Types as Types
+
+-- | Delete a delisted pool if it exists. Returns 'True' if it did exist and has been
+-- deleted and 'False' if it did not exist.
+deleteDelistedPool :: MonadIO m => Types.PoolId -> ReaderT SqlBackend m Bool
+deleteDelistedPool poolId = do
+  keys <- selectKeysList [ DelistedPoolPoolId ==. poolId ] []
+  mapM_ deleteCascade keys
+  pure $ not (null keys)
+

src/Cardano/Db/Error.hs

@@ -26,6 +26,7 @@ data DBFail
   | UnableToEncodePoolMetadataToJSON !Text
   | UnknownError !Text
   | ReservedTickerAlreadyInserted !Text
+  | RecordDoesNotExist
   deriving (Eq, Show, Generic)
 
 {-
@@ -86,7 +87,11 @@ instance ToJSON DBFail where
             [ "code"            .= String "ReservedTickerAlreadyInserted"
             , "description"     .= String (renderLookupFail failure)
             ]
-
+    toJSON failure@(RecordDoesNotExist) =
+        object
+            [ "code"            .= String "RecordDoesNotExist"
+            , "description"     .= String (renderLookupFail failure)
+            ]
 
 renderLookupFail :: DBFail -> Text
 renderLookupFail lf =
@@ -100,4 +105,5 @@ renderLookupFail lf =
     UnableToEncodePoolMetadataToJSON err -> "Unable to encode the content to JSON. " <> err
     UnknownError text -> "Unknown error. Context: " <> text
     ReservedTickerAlreadyInserted tickerName -> "Ticker '" <> tickerName <> "' has already been inserted."
+    RecordDoesNotExist -> "The requested record does not exist."
 

src/Cardano/Db/Schema.hs

@@ -114,7 +114,7 @@ share
   -- A table containing a list of delisted pools.
   DelistedPool
     poolId              Types.PoolId        sqltype=text
-    UniqueBlacklistedPool poolId
+    UniqueDelistedPool poolId
 
   -- A table containing a managed list of reserved ticker names.
   -- For now they are grouped under the specific hash of the pool.

src/DB.hs

@@ -23,6 +23,7 @@ import           Data.Time.Clock.POSIX        (utcTimeToPOSIXSeconds)
 
 import           Types
 
+import           Cardano.Db.Delete            (deleteDelistedPool)
 import           Cardano.Db.Insert            (insertDelistedPool,
                                                insertPoolMetadata,
                                                insertPoolMetadataFetchError,
@@ -65,6 +66,7 @@ data DataLayer = DataLayer
     , dlGetDelistedPools        :: IO [PoolId]
     , dlCheckDelistedPool       :: PoolId -> IO Bool
     , dlAddDelistedPool         :: PoolId -> IO (Either DBFail PoolId)
+    , dlRemoveDelistedPool      :: PoolId -> IO (Either DBFail PoolId)
 
     , dlGetAdminUsers           :: IO (Either DBFail [AdminUser])
 
@@ -86,28 +88,25 @@ stubbedDataLayer ioDataMap ioDelistedPool = DataLayer
         case (Map.lookup (poolId, poolmdHash) ioDataMap') of
             Just poolOfflineMetadata'   -> return . Right $ ("Test", 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)
         return . Right $ poolMetadata
 
-    , dlAddReservedTicker = \tickerName poolMetadataHash -> panic "!"
+    , dlAddMetaDataReference = \poolId poolUrl poolMetadataHash -> panic "!"
 
+    , dlAddReservedTicker = \tickerName poolMetadataHash -> panic "!"
     , dlCheckReservedTicker = \tickerName -> panic "!"
 
-    , dlAddMetaDataReference = \poolId poolUrl poolMetadataHash -> panic "!"
-
     , dlGetDelistedPools = readIORef ioDelistedPool
-
     , dlCheckDelistedPool = \poolId -> do
         blacklistedPool' <- readIORef ioDelistedPool
         return $ poolId `elem` blacklistedPool'
-
     , dlAddDelistedPool  = \poolId -> do
-        _ <- modifyIORef ioDelistedPool (\pool -> [poolId] ++ pool)
-        -- TODO(KS): Do I even need to query this?
-        _blacklistedPool' <- readIORef ioDelistedPool
+        _ <- modifyIORef ioDelistedPool (\pools -> [poolId] ++ pools)
+        return $ Right poolId
+    , dlRemoveDelistedPool = \poolId -> do
+        _ <- modifyIORef ioDelistedPool (\pools -> filter (/= poolId) pools)
         return $ Right poolId
 
     , dlGetAdminUsers       = return $ Right []
@@ -132,9 +131,7 @@ postgresqlDataLayer = DataLayer
         poolMetadata <- runDbAction Nothing $ queryPoolMetadata poolId poolMetadataHash
         let poolTickerName = Types.getTickerName . poolMetadataTickerName <$> poolMetadata
         let poolMetadata' = Types.getPoolMetadata . poolMetadataMetadata <$> poolMetadata
-        -- Ugh. Very sorry about this.
         return $ (,) <$> poolTickerName <*> poolMetadata'
-
     , dlAddPoolMetadata     = \ mRefId poolId poolHash poolMetadata poolTicker -> do
         let poolTickerName = Types.TickerName $ getPoolTicker poolTicker
         _ <- runDbAction Nothing $ insertPoolMetadata $ PoolMetadata poolId poolTickerName poolHash (Types.PoolMetadataRaw poolMetadata) mRefId
@@ -151,21 +148,24 @@ postgresqlDataLayer = DataLayer
 
     , dlAddReservedTicker = \tickerName poolMetadataHash ->
         runDbAction Nothing $ insertReservedTicker $ ReservedTicker tickerName poolMetadataHash
-
     , dlCheckReservedTicker = \tickerName ->
         runDbAction Nothing $ queryReservedTicker tickerName
 
     , dlGetDelistedPools = do
         delistedPoolsDB <- runDbAction Nothing queryAllDelistedPools
         -- Convert from DB-specific type to the "general" type
         return $ map (\delistedPoolDB -> PoolId . getPoolId $ delistedPoolPoolId delistedPoolDB) delistedPoolsDB
-
     , dlCheckDelistedPool = \poolId -> do
         runDbAction Nothing $ queryDelistedPool poolId
-
     , dlAddDelistedPool  = \poolId -> do
         delistedPoolId <- runDbAction Nothing $ insertDelistedPool $ DelistedPool poolId
         return $ Right poolId
+    , dlRemoveDelistedPool = \poolId -> do
+        isDeleted <- runDbAction Nothing $ deleteDelistedPool poolId
+        -- Up for a discussion, but this might be more sensible in the lower DB layer.
+        if isDeleted
+            then return $ Right poolId
+            else return $ Left RecordDoesNotExist
 
     , dlGetAdminUsers       = do
         adminUsers <- runDbAction Nothing $ queryAdminUsers
@@ -174,11 +174,9 @@ postgresqlDataLayer = DataLayer
     , dlAddFetchError       = \poolMetadataFetchError -> do
         poolMetadataFetchErrorId <- runDbAction Nothing $ insertPoolMetadataFetchError poolMetadataFetchError
         return $ Right poolMetadataFetchErrorId
-
     , dlGetFetchErrors      = \mPoolId -> do
         poolMetadataFetchErrors <- runDbAction Nothing (queryPoolMetadataFetchError mPoolId)
         pure $ sequence $ Right <$> map convertPoolMetadataFetchError poolMetadataFetchErrors
-
     }
 
 convertPoolMetadataFetchError :: PoolMetadataFetchError -> PoolFetchError

src/Lib.hs

@@ -56,17 +56,26 @@ type DelistedPoolsAPI = "api" :> "v1" :> "delisted" :> ApiRes Get [PoolId]
 #ifdef DISABLE_BASIC_AUTH
 type DelistPoolAPI = "api" :> "v1" :> "delist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
 
+type EnlistPoolAPI = "api" :> "v1" :> "enlist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
+
 type FetchPoolErrorAPI = "api" :> "v1" :> "errors" :> QueryParam "poolId" PoolId :> ApiRes Get [PoolFetchError]
 #else
 -- The basic auth.
 type BasicAuthURL = BasicAuth "smash" User
 
 type DelistPoolAPI = BasicAuthURL :> "api" :> "v1" :> "delist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
 
+type EnlistPoolAPI = BasicAuthURL :> "api" :> "v1" :> "enlist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
+
 type FetchPoolErrorAPI = BasicAuthURL :> "api" :> "v1" :> "errors" :> QueryParam "poolId" PoolId :> ApiRes Get [PoolFetchError]
 #endif
 
-type SmashAPI = OfflineMetadataAPI :<|> DelistPoolAPI :<|> FetchPoolErrorAPI :<|> DelistedPoolsAPI
+-- The full API.
+type SmashAPI =  OfflineMetadataAPI
+            :<|> DelistedPoolsAPI
+            :<|> DelistPoolAPI
+            :<|> EnlistPoolAPI
+            :<|> FetchPoolErrorAPI
 
 -- | Swagger spec for Todo API.
 todoSwagger :: Swagger
@@ -82,7 +91,7 @@ todoSwagger =
         Nothing
         Nothing
         Nothing
-        "0.0.1"
+        "1.1.0"
 
 -- | API for serving @swagger.json@.
 type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger
@@ -97,10 +106,6 @@ fullAPI = Proxy
 smashApi :: Proxy SmashAPI
 smashApi = Proxy
 
--- 403 if it is delisted
--- 404 if it is not available (e.g. it could not be downloaded, or was invalid)
--- 200 with the JSON content. Note that this must be the original content with the expected hash, not a re-rendering of the original.
-
 runApp :: Configuration -> IO ()
 runApp configuration = do
     let port = cPortNumber configuration
@@ -223,48 +228,15 @@ server :: Configuration -> DataLayer -> Server API
 server configuration dataLayer
     =       return todoSwagger
     :<|>    getPoolOfflineMetadata dataLayer
-    :<|>    postDelistPool dataLayer
-    :<|>    fetchPoolErrorAPI dataLayer
     :<|>    getDelistedPools dataLayer
-
-#ifdef DISABLE_BASIC_AUTH
-fetchPoolErrorAPI :: DataLayer -> Maybe PoolId -> Handler (ApiResult DBFail [PoolFetchError])
-fetchPoolErrorAPI dataLayer mPoolId = convertIOToHandler $ do
-
-    let getFetchErrors = dlGetFetchErrors dataLayer
-    fetchErrors <- getFetchErrors mPoolId
-
-    return . ApiResult $ fetchErrors
-#else
-fetchPoolErrorAPI :: DataLayer -> User -> Maybe PoolId -> Handler (ApiResult DBFail [PoolFetchError])
-fetchPoolErrorAPI dataLayer _user mPoolId = convertIOToHandler $ do
-
-    let getFetchErrors = dlGetFetchErrors dataLayer
-    fetchErrors <- getFetchErrors mPoolId
-
-    return . ApiResult $ fetchErrors
-#endif
-
-#ifdef DISABLE_BASIC_AUTH
-postDelistPool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId)
-postDelistPool dataLayer poolId = convertIOToHandler $ do
-
-    let addDelistedPool = dlAddDelistedPool dataLayer
-    delistedPool' <- addDelistedPool poolId
-
-    return . ApiResult $ delistedPool'
-#else
-postDelistPool :: DataLayer -> User -> PoolId -> Handler (ApiResult DBFail PoolId)
-postDelistPool dataLayer user poolId = convertIOToHandler $ do
-
-    let addDelistedPool = dlAddDelistedPool dataLayer
-    delistedPool' <- addDelistedPool poolId
-
-    return . ApiResult $ delistedPool'
-#endif
+    :<|>    delistPool dataLayer
+    :<|>    enlistPool dataLayer
+    :<|>    fetchPoolErrorAPI dataLayer
 
 
--- throwError err404
+-- 403 if it is delisted
+-- 404 if it is not available (e.g. it could not be downloaded, or was invalid)
+-- 200 with the JSON content. Note that this must be the original content with the expected hash, not a re-rendering of the original.
 getPoolOfflineMetadata
     :: DataLayer
     -> PoolId
@@ -306,6 +278,68 @@ getDelistedPools dataLayer = convertIOToHandler $ do
     allDelistedPools <- getAllDelisted
     return . ApiResult . Right $ allDelistedPools
 
+
+#ifdef DISABLE_BASIC_AUTH
+delistPool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId)
+delistPool dataLayer poolId = convertIOToHandler $ do
+
+    let addDelistedPool = dlAddDelistedPool dataLayer
+    delistedPool' <- addDelistedPool poolId
+
+    return . ApiResult $ delistedPool'
+#else
+delistPool :: DataLayer -> User -> PoolId -> Handler (ApiResult DBFail PoolId)
+delistPool dataLayer user poolId = convertIOToHandler $ do
+
+    let addDelistedPool = dlAddDelistedPool dataLayer
+    delistedPool' <- addDelistedPool poolId
+
+    return . ApiResult $ delistedPool'
+#endif
+
+
+#ifdef DISABLE_BASIC_AUTH
+enlistPool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId)
+enlistPool dataLayer poolId = convertIOToHandler $ do
+
+    let removeDelistedPool = dlRemoveDelistedPool dataLayer
+    delistedPool' <- removeDelistedPool poolId
+
+    case delistedPool' of
+        Left err -> throwIO err404
+        Right poolId' -> return . ApiResult . Right $ poolId
+#else
+enlistPool :: DataLayer -> User -> PoolId -> Handler (ApiResult DBFail PoolId)
+enlistPool dataLayer user poolId = convertIOToHandler $ do
+
+    let removeDelistedPool = dlRemoveDelistedPool dataLayer
+    delistedPool' <- removeDelistedPool poolId
+
+    case delistedPool' of
+        Left err -> throwIO err404
+        Right poolId' -> return . ApiResult . Right $ poolId'
+#endif
+
+
+#ifdef DISABLE_BASIC_AUTH
+fetchPoolErrorAPI :: DataLayer -> Maybe PoolId -> Handler (ApiResult DBFail [PoolFetchError])
+fetchPoolErrorAPI dataLayer mPoolId = convertIOToHandler $ do
+
+    let getFetchErrors = dlGetFetchErrors dataLayer
+    fetchErrors <- getFetchErrors mPoolId
+
+    return . ApiResult $ fetchErrors
+#else
+fetchPoolErrorAPI :: DataLayer -> User -> Maybe PoolId -> Handler (ApiResult DBFail [PoolFetchError])
+fetchPoolErrorAPI dataLayer _user mPoolId = convertIOToHandler $ do
+
+    let getFetchErrors = dlGetFetchErrors dataLayer
+    fetchErrors <- getFetchErrors mPoolId
+
+    return . ApiResult $ fetchErrors
+#endif
+
+
 -- For now, we just ignore the @BasicAuth@ definition.
 instance (HasSwagger api) => HasSwagger (BasicAuth name typo :> api) where
     toSwagger _ = toSwagger (Proxy :: Proxy api)