Wire new 'order' query parameter through the API.

CardanoSolutions · Sep 29, 2022 · 81d41e5 · 81d41e5
1 parent 006c5fd
commit 81d41e5
Show file tree

Hide file tree

Showing 8 changed files with 179 additions and 32 deletions.
diff --git a/src/Kupo/App/Database.hs b/src/Kupo/App/Database.hs
@@ -87,6 +87,7 @@ import Kupo.Data.Database
     , Checkpoint (..)
     , Input (..)
     , ScriptReference (..)
+    , SortDirection (..)
     )
 import Numeric
     ( Floating (..)
@@ -120,6 +121,7 @@ data Database (m :: Type -> Type) = Database
 
     , foldInputs
         :: Text  -- An address-like query
+        -> SortDirection
         -> (Input -> m ())
         -> DBTransaction m ()
 
@@ -349,19 +351,26 @@ mkDatabase tr longestRollback bracketConnection = Database
                 ]
             changes conn
 
-    , foldInputs = \whereClause yield -> ReaderT $ \conn -> do
-        -- TODO: Move upward and make configurable by users.
-        let ordering = "DESC"
-        let qry = "SELECT output_reference, address, value, datum_hash, script_hash ,\
+    , foldInputs = \whereClause sortDirection yield -> ReaderT $ \conn -> do
+        let qry = "SELECT \
+                    \output_reference, address, value, datum_hash, script_hash ,\
                     \created_at, createdAt.header_hash, \
                     \spent_at, spentAt.header_hash \
                   \FROM inputs \
-                  \JOIN checkpoints AS createdAt ON createdAt.slot_no = created_at \
-                  \LEFT OUTER JOIN checkpoints AS spentAt ON spentAt.slot_no = spent_at \
-                  \WHERE " <> whereClause <> " \
+                  \JOIN \
+                    \checkpoints AS createdAt ON createdAt.slot_no = created_at \
+                  \LEFT OUTER JOIN \
+                    \checkpoints AS spentAt ON spentAt.slot_no = spent_at \
+                  \WHERE "
+                    <> whereClause <> " \
                   \ORDER BY \
                     \created_at " <> ordering <> ", \
-                    \substr(output_reference, -2) " <> ordering
+                    \substr(output_reference, -2) " <> ordering <> ", \
+                    \substr(output_reference, -4, 2) " <> ordering
+              where
+                ordering = case sortDirection of
+                    Asc -> "ASC"
+                    Desc -> "DESC"
 
         -- TODO: Allow resolving datums / scripts on demand through LEFT JOIN
         --

diff --git a/src/Kupo/App/Http.hs b/src/Kupo/App/Http.hs
@@ -61,6 +61,7 @@ import Kupo.Data.Database
     ( applyStatusFlag
     , binaryDataFromRow
     , datumHashToRow
+    , mkSortDirection
     , patternToRow
     , patternToSql
     , pointFromRow
@@ -85,6 +86,9 @@ import Kupo.Data.Http.GetCheckpointMode
     ( GetCheckpointMode (..)
     , getCheckpointModeFromQuery
     )
+import Kupo.Data.Http.OrderMatchesBy
+    ( orderMatchesBy
+    )
 import Kupo.Data.Http.Response
     ( responseJson
     , responseJsonEncoding
@@ -410,13 +414,16 @@ handleGetMatches headers patternQuery queryParams Database{..} = either id id $
     statusFlag <- statusFlagFromQueryParams queryParams
         `orAbort` Errors.invalidStatusFlag
 
-    let query = applyStatusFlag statusFlag (patternToSql p)
-
     yieldIf <- (mkYieldIf p <$> filterMatchesBy queryParams)
         `orAbort` Errors.invalidMatchFilter
 
+    sortDirection <- mkSortDirection <$> orderMatchesBy queryParams
+        `orAbort` Errors.invalidSortDirection
+
+    let query = applyStatusFlag statusFlag (patternToSql p)
+
     pure $ responseStreamJson headers resultToJson $ \yield done -> do
-        runReadOnlyTransaction $ foldInputs query (yieldIf yield . resultFromRow)
+        runReadOnlyTransaction $ foldInputs query sortDirection (yieldIf yield . resultFromRow)
         done
   where
     -- NOTE: kupo does support two different ways for fetching results, via query parameters or via

diff --git a/src/Kupo/Data/Database.hs b/src/Kupo/Data/Database.hs
@@ -52,6 +52,10 @@ module Kupo.Data.Database
 
       -- * Filtering
     , applyStatusFlag
+
+      -- * Sorting
+    , SortDirection (..)
+    , mkSortDirection
     ) where
 
 import Kupo.Prelude
@@ -80,6 +84,9 @@ import Kupo.Data.Cardano
     , transactionIdToBytes
     , unsafeTransactionIdFromBytes
     )
+import Kupo.Data.Http.OrderMatchesBy
+    ( OrderMatchesBy (..)
+    )
 import Kupo.Data.Http.StatusFlag
     ( StatusFlag (..)
     )
@@ -619,3 +626,12 @@ applyStatusFlag = \case
         (<> " AND spent_at IS NULL")
     OnlySpent ->
         (<> " AND spent_at IS NOT NULL")
+
+data SortDirection = Asc | Desc
+    deriving (Generic)
+
+mkSortDirection :: OrderMatchesBy -> SortDirection
+mkSortDirection = \case
+    MostRecentFirst -> Desc
+    NoExplicitOrder -> Desc
+    OldestFirst -> Asc
diff --git a/src/Kupo/Data/Http/Error.hs b/src/Kupo/Data/Http/Error.hs
@@ -107,6 +107,14 @@ malformedPoint =
                  \a point). Please refer to the API reference for details <https://cardanosolutions.github.io/kupo>."
         }
 
+invalidSortDirection :: Response
+invalidSortDirection =
+    responseJson status400 Default.headers $ HttpError
+        { hint = "Invalid sort direction provided as query parameter. \
+                 \You can specify either 'order=most_recent_first' or \
+                 \'order=oldest_first'. Please refer to the API reference for details <https://cardanosolutions.github.io/kupo#operation/getAllMatches>."
+        }
+
 unsafeRollbackBeyondSafeZone :: Response
 unsafeRollbackBeyondSafeZone =
     responseJson status400 Default.headers $ HttpError

diff --git a/src/Kupo/Prelude.hs b/src/Kupo/Prelude.hs
@@ -88,6 +88,9 @@ import Data.Generics.Internal.VL.Lens
 import Data.List
     ( nubBy
     )
+import Data.Sequence.Strict
+    ( StrictSeq
+    )
 import GHC.Generics
     ( Rep
     )
@@ -131,6 +134,11 @@ import Relude hiding
     , tryTakeTMVar
     , writeTVar
     )
+import Relude.Extra
+    ( next
+    , prev
+    , safeToEnum
+    )
 import System.Posix.Signals
     ( Handler (..)
     , installHandler
@@ -146,14 +154,6 @@ import qualified Data.Aeson.Parser as Json
 import qualified Data.Aeson.Parser.Internal as Json
 import qualified Data.Aeson.Types as Json
 import qualified Data.ByteString.Base58 as Base58
-import Data.Sequence.Strict
-    ( StrictSeq
-    )
-import Relude.Extra
-    ( next
-    , prev
-    , safeToEnum
-    )
 
 data ConnectionStatusToggle m = ConnectionStatusToggle
     { toggleConnected :: !(m ())

diff --git a/test/Test/Kupo/App/HttpSpec.hs b/test/Test/Kupo/App/HttpSpec.hs
@@ -324,6 +324,14 @@ spec = do
             resBadRequest
                 & Wai.assertHeader Http.hContentType (renderHeader mediaTypeJson)
 
+        session' "🕱 GET /matches?order=foo" $ do
+            resBadRequest <- Wai.request $ Wai.defaultRequest
+                & flip Wai.setPath "/matches?order=foo"
+            resBadRequest
+                & Wai.assertStatus (Http.statusCode Http.status400)
+            resBadRequest
+                & Wai.assertHeader Http.hContentType (renderHeader mediaTypeJson)
+
         session' "🕱 DELETE /matches/{pattern}" $ do
             overlappingFragment <- liftIO $ generate (elements Fixture.overlappingUnaryFragments)
             resBadRequest <- Wai.request $ Wai.defaultRequest
@@ -429,7 +437,7 @@ databaseStub = Database
         10
     , insertInputs =
         \_ -> return ()
-    , foldInputs = \_ callback -> lift $ do
+    , foldInputs = \_ _ callback -> lift $ do
         rows <- fmap resultToRow <$> generate (listOf1 genResult)
         mapM_ callback rows
     , deleteInputsByAddress =