Implement search queries

src/Lib.hs

@@ -29,6 +29,7 @@ import Data.OpenApi
     ToSchema,
     URL (URL),
   )
+import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Typeable (Typeable)
 import Data.UUID
@@ -343,6 +344,7 @@ searchCards dbFile q sortBy inCollection =
           [sql|card_prices ON (cards.scryfall_id = card_prices.scryfall_id)
              AND card_prices.date = (SELECT value FROM vars WHERE key = :last_update_key)|]
         <> join "rarities ON (cards.rarity = rarities.rarity)"
+        <> conditions
         <> orderBy "rarities.rarity_ord DESC"
         <> orderBy "length(cards.color_identity) DESC"
         <> orderBy
@@ -352,12 +354,88 @@ searchCards dbFile q sortBy inCollection =
         <> parameter ":last_update_key" ("last_update" :: T.Text)
         <> limit 10
     query =
-      mconcat $ catMaybes
-        [ case sortBy of
-            Just "price" -> Just $ orderBy "CAST(COALESCE(card_prices.usd, card_prices.usd_foil) as decimal) DESC"
-            _ -> Nothing,
-          Just baseQuery,
-          case inCollection of
-            Just "no" -> Nothing
-            _ -> Just $ join "copies ON (cards.scryfall_id = copies.scryfall_id)"
-        ]
+      mconcat $
+        catMaybes
+          [ case sortBy of
+              Just "price" -> Just $ orderBy "CAST(COALESCE(card_prices.usd, card_prices.usd_foil) as decimal) DESC"
+              _ -> Nothing,
+            Just baseQuery,
+            case inCollection of
+              Just "no" -> Nothing
+              _ -> Just $ join "copies ON (cards.scryfall_id = copies.scryfall_id)"
+          ]
+    conditions = case parseQuery (fromMaybe "" q) of
+      Right (Search xs) -> mconcat $ [fromNamedCriteria p x | (p, x) <- zip whereParams xs]
+      Left _ -> mempty
+
+    whereParams :: [T.Text]
+    whereParams = [":where_" <> T.pack (show n) | n <- [1 ..]]
+
+    fromNamedCriteria :: T.Text -> Criteria -> Select Query
+    fromNamedCriteria param (NameContains txt) =
+      whereNamedParam "cards.name" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (ExpansionCodeIs txt) =
+      whereNamedParam "cards.set_code" "LIKE" param txt
+    fromNamedCriteria param (CardTypeContains txt) =
+      whereNamedParam "cards.type_line" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (OracleTextContains txt) =
+      whereNamedParam "cards.oracle_text" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (ColorIdentityIs colors) =
+      whereNamedParam
+        "cards.color_identity"
+        "LIKE"
+        param
+        (mconcat $ fromColors colors)
+    fromNamedCriteria param (ColorIdentityLTE colors) =
+      if L.null colorList
+        then mempty
+        else
+          mconcat
+            [ where_ $
+                mconcat
+                  [ "(",
+                    sqlJoin
+                      " OR "
+                      ( "cards.color_identity LIKE " <> Query param :
+                          [ "cards.color_identity LIKE " <> Query colorParam
+                            | colorParam <- colorParams
+                          ]
+                      ),
+                    ")"
+                  ],
+              parameter param $ mconcat colorList,
+              mconcat
+                [ parameter colorParam color
+                  | (colorParam, color) <- zip colorParams colorList
+                ]
+            ]
+      where
+        colorList = fromColors colors
+        colorParams = [param <> "_" <> color | color <- colorList]
+    fromNamedCriteria param (ColorIdentityGTE colors) =
+      whereNamedParam
+        "cards.color_identity"
+        "LIKE"
+        param
+        ("%" <> mconcat (fromColors colors) <> "%")
+    fromNamedCriteria param (RarityIs rarity) =
+      whereNamedParam "cards.rarity" "LIKE" param (rarityName rarity)
+    fromNamedCriteria param (RarityLTE rarity) =
+      whereNamedParam "rarities.rarity_ord" "<=" param (rarityValue rarity)
+    fromNamedCriteria param (RarityGTE rarity) =
+      whereNamedParam "rarities.rarity_ord" ">=" param (rarityValue rarity)
+
+    fromColors :: Colors -> [T.Text]
+    fromColors (Colors colors) = map (T.pack . show) (S.toList colors)
+
+    rarityName :: Rarity -> T.Text
+    rarityName Common = "common"
+    rarityName Uncommon = "uncommon"
+    rarityName Rare = "rare"
+    rarityName Mythic = "mythic"
+
+    rarityValue :: Rarity -> Int
+    rarityValue Common = 1
+    rarityValue Uncommon = 2
+    rarityValue Rare = 3
+    rarityValue Mythic = 5

src/Search.hs

@@ -22,16 +22,16 @@ data Criteria
 data Color
   = Colorless
   | White
-  | Black
   | Blue
+  | Black
   | Green
   | Red
   deriving (Eq, Ord)
 
 instance Show Color where
   show White = "W"
-  show Black = "B"
   show Blue = "U"
+  show Black = "B"
   show Green = "G"
   show Red = "R"
 

src/Select.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Select
-  ( toQuery,
+  ( Select,
+    toQuery,
     selectSimple,
     selectWhere,
     selectParameters,
@@ -9,10 +10,12 @@ module Select
     table,
     join,
     where_,
+    whereNamedParam,
     orderBy,
     limit,
     limitOffset,
     parameter,
+    sqlJoin,
   )
 where
 
@@ -53,7 +56,17 @@ instance Semigroup (Select a) where
       pickLast a Nothing = a
 
 instance Monoid (Select a) where
-  mempty = selectSimple [] []
+  mempty =
+    Select
+      { selectColumns = [],
+        selectTables = [],
+        selectJoins = [],
+        selectCriteria = [],
+        selectOrdering = [],
+        selectLimit = Nothing,
+        selectOffset = Nothing,
+        selectParameters = []
+      }
 
 toQuery :: (Monoid a, Data.String.IsString a) => Select a -> a
 toQuery select =
@@ -91,22 +104,46 @@ sqlJoin :: (Monoid a, Data.String.IsString a) => a -> [a] -> a
 sqlJoin joiner snippets =
   mconcat $ Data.List.intercalate [joiner] [[s] | s <- snippets]
 
-selectSimple columns tables = Select columns tables [] [] [] Nothing Nothing []
+selectSimple columns tables =
+  mempty
+    { selectColumns = columns,
+      selectTables = tables
+    }
 
-selectWhere columns tables criteria = Select columns tables criteria [] [] Nothing Nothing []
+selectWhere columns tables criteria =
+  mempty
+    { selectColumns = columns,
+      selectTables = tables,
+      selectCriteria = criteria
+    }
 
-column x = selectSimple [x] []
+column x = mempty {selectColumns = [x]}
 
-table x = selectSimple [] [x]
+table x = mempty {selectTables = [x]}
 
-where_ x = selectWhere [] [] [x]
+where_ x = mempty {selectCriteria = [x]}
 
-join x = Select [] [] [x] [] [] Nothing Nothing []
+whereNamedParam column operator paramName value =
+  mempty
+    { selectCriteria = [sqlJoin " " [column, operator, Query paramName]],
+      selectParameters = [paramName := value]
+    }
 
-orderBy x = Select [] [] [] [] [x] Nothing Nothing []
+join x = mempty {selectJoins = [x]}
 
-limit x = Select [] [] [] [] [] (Just x) Nothing [":__limit" := x]
+orderBy x = mempty {selectOrdering = [x]}
 
-limitOffset x y = Select [] [] [] [] [] (Just x) (Just y) [":__limit" := x, ":__offset" := y]
+limit x =
+  mempty
+    { selectLimit = Just x,
+      selectParameters = [":__limit" := x]
+    }
 
-parameter name value = Select [] [] [] [] [] Nothing Nothing [name := value]
+limitOffset x y =
+  mempty
+    { selectLimit = Just x,
+      selectOffset = Just y,
+      selectParameters = [":__limit" := x, ":__offset" := y]
+    }
+
+parameter name value = mempty {selectParameters = [name := value]}