[CAD-2651] Fix/improve caching.

smash-servant-types/src/Cardano/SMASH/API.hs

@@ -84,7 +84,7 @@ type BasicAuthURL = BasicAuth "smash" User
 type HealthStatusAPI = "api" :> APIVersion :> "status" :> ApiRes Get HealthStatus
 
 -- GET api/v1/metadata/{hash}
-type OfflineMetadataAPI = "api" :> APIVersion :> "metadata" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> Get '[JSON] (Headers '[Header "Cache" Text] (ApiResult DBFail PoolMetadataRaw))
+type OfflineMetadataAPI = "api" :> APIVersion :> "metadata" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> Get '[JSON] (Headers '[Header "Cache-Control" Text] (ApiResult DBFail PoolMetadataRaw))
 
 -- GET api/v1/delisted
 type DelistedPoolsAPI = "api" :> APIVersion :> "delisted" :> ApiRes Get [PoolId]

smash/app/Main.hs

@@ -174,8 +174,7 @@ runCardanoSyncWithSmash dbSyncNodeParams = do
     -- Run metrics server
     --(metrics, server) <- registerMetricsServer 8080
 
-    let dataLayer :: DB.DataLayer
-        dataLayer = DB.postgresqlDataLayer (Just tracer)
+    dataLayer <- DB.createCachedDataLayer (Just tracer)
 
     -- The plugin requires the @DataLayer@.
     let smashDbSyncNodePlugin = poolMetadataDbSyncNodePlugin dataLayer

smash/smash.cabal

@@ -164,8 +164,6 @@ test-suite smash-test
   main-is:            Spec.hs
   other-modules:
     Paths_smash
-    SmashSpec
-    SmashSpecSM
 
   hs-source-dirs:     test
   ghc-options:        -threaded -rtsopts -with-rtsopts=-N

smash/src/Cardano/SMASH/DBSync/Db/Query.hs

@@ -10,6 +10,7 @@ module Cardano.SMASH.DBSync.Db.Query
   , queryLatestSlotNo
   , queryAllPools
   , queryPoolByPoolId
+  , queryAllPoolMetadata
   , queryPoolMetadata
   , queryBlockCount
   , queryBlockNo
@@ -20,6 +21,7 @@ module Cardano.SMASH.DBSync.Db.Query
   , queryCheckPoints
   , queryDelistedPool
   , queryAllDelistedPools
+  , queryAllReservedTickers
   , queryReservedTicker
   , queryAdminUsers
   , queryPoolMetadataFetchError
@@ -103,14 +105,20 @@ queryPoolByPoolId poolId = do
         subList_select . from $ \(retiredPool :: SqlExpr (Entity RetiredPool)) ->
         return $ retiredPool ^. RetiredPoolPoolId
 
+-- |Return all retired pools.
+queryAllPoolMetadata :: MonadIO m => ReaderT SqlBackend m [PoolMetadata]
+queryAllPoolMetadata = do
+  res <- selectList [] []
+  pure $ entityVal <$> res
+
 -- | Get the 'Block' associated with the given hash.
 -- We use the @Types.PoolId@ to get the nice error message out.
 queryPoolMetadata :: MonadIO m => Types.PoolId -> Types.PoolMetadataHash -> ReaderT SqlBackend m (Either DBFail PoolMetadata)
 queryPoolMetadata poolId poolMetadataHash' = do
   res <- select . from $ \ poolMetadata -> do
             where_ (poolMetadata ^. PoolMetadataPoolId ==. val poolId
                 &&. poolMetadata ^. PoolMetadataHash ==. val poolMetadataHash'
-                &&. poolMetadata ^. PoolMetadataPoolId `notIn` retiredPoolsPoolId)
+                &&. poolMetadata ^. PoolMetadataPoolId `notIn` retiredPoolsPoolId) -- This is now optional
             pure poolMetadata
   pure $ maybeToEither (DbLookupPoolMetadataHash poolId poolMetadataHash') entityVal (listToMaybe res)
   where
@@ -231,11 +239,19 @@ queryAllDelistedPools = do
   res <- selectList [] []
   pure $ entityVal <$> res
 
+-- |Return all reserved tickers.
+queryAllReservedTickers :: MonadIO m => ReaderT SqlBackend m [ReservedTicker]
+queryAllReservedTickers = do
+  res <- selectList [] []
+  pure $ entityVal <$> res
+
 -- | Check if the ticker is in the table.
-queryReservedTicker :: MonadIO m => Types.TickerName -> ReaderT SqlBackend m (Maybe ReservedTicker)
-queryReservedTicker reservedTickerName' = do
+queryReservedTicker :: MonadIO m => Types.TickerName -> Types.PoolMetadataHash -> ReaderT SqlBackend m (Maybe ReservedTicker)
+queryReservedTicker reservedTickerName' poolMetadataHash' = do
   res <- select . from $ \(reservedTicker :: SqlExpr (Entity ReservedTicker)) -> do
-            where_ (reservedTicker ^. ReservedTickerName ==. val reservedTickerName')
+            where_ (reservedTicker ^. ReservedTickerName ==. val reservedTickerName'
+                &&. reservedTicker ^. ReservedTickerPoolHash ==. val poolMetadataHash')
+
             limit 1
             pure $ reservedTicker
   pure $ fmap entityVal (listToMaybe res)

smash/src/Cardano/SMASH/Lib.hs

@@ -19,8 +19,8 @@ module Cardano.SMASH.Lib
     ) where
 
 #ifdef TESTING_MODE
-import           Cardano.SMASH.Types         (PoolIdBlockNumber (..), TickerName,
-                                              pomTicker)
+import           Cardano.SMASH.Types         (PoolIdBlockNumber (..),
+                                              TickerName, pomTicker)
 import           Data.Aeson                  (eitherDecode')
 import qualified Data.ByteString.Lazy        as BL
 #endif
@@ -39,22 +39,20 @@ import           Data.Version                (showVersion)
 import           Network.Wai.Handler.Warp    (defaultSettings, runSettings,
                                               setBeforeMainLoop, setPort)
 
-import           Servant                     ((:<|>) (..))
 import           Servant                     (Application, BasicAuthCheck (..),
                                               BasicAuthData (..),
                                               BasicAuthResult (..),
                                               Context (..), Handler (..),
                                               Header, Headers, Server, err400,
                                               err403, err404, errBody,
-                                              serveWithContext)
+                                              serveWithContext, (:<|>) (..))
 import           Servant.API.ResponseHeaders (addHeader)
 import           Servant.Swagger             (toSwagger)
 
 import           Cardano.SMASH.API           (API, fullAPI, smashApi)
 import           Cardano.SMASH.DB            (AdminUser (..), DBFail (..),
                                               DataLayer (..),
-                                              createStubbedDataLayer,
-                                              reservedTickerPoolHash)
+                                              createCachedDataLayer)
 
 import           Cardano.SMASH.Types         (ApiResult (..),
                                               ApplicationUser (..),
@@ -71,6 +69,19 @@ import           Cardano.SMASH.Types         (ApiResult (..),
 
 import           Paths_smash                 (version)
 
+-- | Cache control header.
+data CacheControl
+    = NoCache
+    | CacheSeconds Int
+    | CacheOneHour
+    | CacheOneDay
+
+-- | Render the cache control header.
+cacheControlHeader :: CacheControl -> Text
+cacheControlHeader NoCache = "no-store"
+cacheControlHeader (CacheSeconds sec) = "max-age=" <> show sec
+cacheControlHeader CacheOneHour = cacheControlHeader $ CacheSeconds (60 * 60)
+cacheControlHeader CacheOneDay = cacheControlHeader $ CacheSeconds (24 * 60 * 60)
 
 -- | Swagger spec for Todo API.
 todoSwagger :: Swagger
@@ -123,7 +134,7 @@ runAppStubbed configuration = do
 mkAppStubbed :: Configuration -> IO Application
 mkAppStubbed configuration = do
 
-    dataLayer <- createStubbedDataLayer
+    dataLayer <- createCachedDataLayer Nothing
 
     return $ serveWithContext
         fullAPI
@@ -222,8 +233,8 @@ getPoolOfflineMetadata
     :: DataLayer
     -> PoolId
     -> PoolMetadataHash
-    -> Handler ((Headers '[Header "Cache" Text] (ApiResult DBFail PoolMetadataRaw)))
-getPoolOfflineMetadata dataLayer poolId poolHash = fmap (addHeader "always") . convertIOToHandler $ do
+    -> Handler ((Headers '[Header "Cache-Control" Text] (ApiResult DBFail PoolMetadataRaw)))
+getPoolOfflineMetadata dataLayer poolId poolHash = fmap (addHeader $ cacheControlHeader NoCache) . convertIOToHandler $ do
 
     let checkDelistedPool = dlCheckDelistedPool dataLayer
     isDelisted <- checkDelistedPool poolId
@@ -232,6 +243,13 @@ getPoolOfflineMetadata dataLayer poolId poolHash = fmap (addHeader "always") . c
     when (isDelisted) $
         throwIO err403
 
+    let checkRetiredPool = dlCheckRetiredPool dataLayer
+    retiredPoolId <- checkRetiredPool poolId
+
+    -- When that pool id is retired, return 404.
+    when (isRight retiredPoolId) $
+        throwIO err404
+
     let dbGetPoolMetadata = dlGetPoolMetadata dataLayer
     poolRecord <- dbGetPoolMetadata poolId poolHash
 
@@ -243,13 +261,10 @@ getPoolOfflineMetadata dataLayer poolId poolHash = fmap (addHeader "always") . c
 
             -- We now check whether the reserved ticker name has been reserved for the specific
             -- pool hash.
-            reservedTicker <- checkReservedTicker tickerName
+            reservedTicker <- checkReservedTicker tickerName poolHash
             case reservedTicker of
                 Nothing -> return . ApiResult . Right $ poolMetadata
-                Just foundReservedTicker ->
-                    if (reservedTickerPoolHash foundReservedTicker) == poolHash
-                        then return . ApiResult . Right $ poolMetadata
-                        else throwIO err404
+                Just _foundReservedTicker -> throwIO err404
 
 -- |Simple health status, there are ideas for improvement.
 getHealthStatus :: Handler (ApiResult DBFail HealthStatus)
@@ -340,7 +355,7 @@ getRetiredPools dataLayer = convertIOToHandler $ do
     let getRetiredPools' = dlGetRetiredPools dataLayer
     retiredPools <- getRetiredPools'
 
-    return . ApiResult $ retiredPools
+    return . ApiResult $ map (fmap fst) retiredPools
 
 checkPool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId)
 checkPool dataLayer poolId = convertIOToHandler $ do