Implement search queries

app/Main.hs

@@ -1,6 +1,10 @@
 module Main where
 
 import Lib
+import Data.Maybe
+import System.Environment
 
 main :: IO ()
-main = startApp
+main = do
+  dbFile <- lookupEnv "TUTOR_DATABASE"
+  startApp (fromMaybe "tutor.db" dbFile)

package.yaml

@@ -28,6 +28,7 @@ dependencies:
 - parsec-extra
 - servant-openapi3
 - servant-server
+- sqlite-simple
 - text
 - uuid
 - wai

src/Lib.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Lib
@@ -11,19 +12,41 @@ module Lib
 where
 
 import Control.Lens
+import qualified Control.Lens as Database.SQLite
+import Control.Monad.IO.Class
 import Data.Aeson
 import Data.Aeson.TH
+import qualified Data.List as L
 import Data.Maybe
-import Data.OpenApi hiding (Server, name, server)
+import Data.OpenApi
+  ( HasDescription (description),
+    HasInfo (info),
+    HasLicense (license),
+    HasTitle (title),
+    HasUrl (url),
+    HasVersion (version),
+    OpenApi,
+    ToSchema,
+    URL (URL),
+  )
+import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Typeable (Typeable)
 import Data.UUID
 import Data.Version (showVersion)
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.Internal
+import Database.SQLite.Simple.Ok
+import Database.SQLite.Simple.QQ
 import GHC.Generics
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Network.Wai.Logger
 import qualified Paths_tutor as PT
+import Search
+import SearchParser
+import Select
 import Servant
   ( Description,
     Get,
@@ -41,6 +64,10 @@ import Servant
   )
 import Servant.OpenApi (HasOpenApi (toOpenApi))
 
+instance FromField UUID where
+  fromField (Field (SQLText txt) _) = Ok $ fromMaybe nil $ fromText txt
+  fromField f = returnError ConversionFailed f "need a text"
+
 data Status = Status
   {apiVersion :: T.Text}
   deriving (Generic, Typeable)
@@ -84,10 +111,44 @@ instance ToJSON Card
 
 instance ToSchema Card
 
+instance FromRow Card where
+  fromRow = do
+    scryfall_id <- field
+    name <- field
+    set_code <- field
+    collector_number <- field
+    rarity <- field
+    color_identity <- field
+    oracle_text <- field
+    price_usd <- field
+    price_usd_foil <- field
+    price_eur <- field
+    price_eur_foil <- field
+    price_tix <- field
+    return $
+      Card
+        { scryfall_id = scryfall_id,
+          name = name,
+          set_code = set_code,
+          collector_number = collector_number,
+          rarity = rarity,
+          color_identity = color_identity,
+          oracle_text = oracle_text,
+          prices =
+            Prices
+              { usd = price_usd,
+                usd_foil = price_usd_foil,
+                eur = price_eur,
+                eur_foil = price_eur_foil,
+                tix = price_tix
+              }
+        }
+
 type GetStatus =
   Summary "Get API Status"
     :> Description "Get the current running API version."
-    :> "api" :> "status"
+    :> "api"
+    :> "status"
     :> Get '[JSON] Status
 
 type SearchCards =
@@ -196,6 +257,8 @@ type SearchCards =
          \: `:` (matches)"
     :> "search"
     :> QueryParam' '[Description "Query string"] "q" T.Text
+    :> QueryParam' '[Description "Sorting method"] "sort_by" T.Text
+    :> QueryParam' '[Description "Search across collection or all cards"] "in_collection" T.Text
     :> Get '[JSON] [Card]
 
 type TutorAPI =
@@ -209,12 +272,12 @@ type ElmAPI = Raw
 
 type API = TutorAPI :<|> DocsAPI :<|> ElmAPI
 
-startApp :: IO ()
-startApp = withStdoutLogger $ \logger ->
-  runSettings (setPort 8080 $ setLogger logger $ defaultSettings) app
+startApp :: FilePath -> IO ()
+startApp dbFile = withStdoutLogger $ \logger ->
+  runSettings (setPort 8080 $ setLogger logger $ defaultSettings) (app dbFile)
 
-app :: Application
-app = serve api server
+app :: FilePath -> Application
+app dbFile = serve api $ server dbFile
 
 tutorAPI :: Proxy TutorAPI
 tutorAPI = Proxy
@@ -230,8 +293,8 @@ openapi =
     & info . description ?~ "An API for searching a Magic: The Gathering card collection."
     & info . license ?~ ("MIT" & url ?~ URL "http://mit.com")
 
-tutorServer :: Server TutorAPI
-tutorServer = status :<|> cards
+tutorServer :: FilePath -> Server TutorAPI
+tutorServer dbFile = status :<|> searchCards dbFile
 
 docsServer :: Server DocsAPI
 docsServer = return openapi
@@ -239,8 +302,8 @@ docsServer = return openapi
 elmServer :: Server ElmAPI
 elmServer = serveDirectoryFileServer "www/public"
 
-server :: Server API
-server = tutorServer :<|> docsServer :<|> elmServer
+server :: FilePath -> Server API
+server dbFile = tutorServer dbFile :<|> docsServer :<|> elmServer
 
 packageVersion :: T.Text
 packageVersion = T.pack $ showVersion PT.version
@@ -252,58 +315,127 @@ status =
       { apiVersion = packageVersion
       }
 
-cards :: Maybe T.Text -> Handler [Card]
-cards q =
-  return
-    [ Card
-        { scryfall_id = fromJust $ fromText "f6cd7465-9dd0-473c-ac5e-dd9e2f22f5f6",
-          name = "Esika, God of the Tree // The Prismatic Bridge",
-          set_code = "KHM",
-          collector_number = "168",
-          rarity = "mythic",
-          color_identity = "WUBGR",
-          oracle_text = Nothing,
-          prices =
-            Prices
-              { usd = Just "9.07",
-                usd_foil = Just "10.77",
-                eur = Just "7.79",
-                eur_foil = Just "12.27",
-                tix = Just "1.08"
-              }
-        },
-      Card
-        { scryfall_id = fromJust $ fromText "d761ff73-0717-4ee4-996b-f5547bcf9b2f",
-          name = "Go-Shintai of Life's Origin",
-          set_code = "NEC",
-          collector_number = "66",
-          rarity = "mythic",
-          color_identity = "WUBGR",
-          oracle_text = Just "{W}{U}{B}{R}{G}, {T}: Return target enchantment card from your graveyard to the battlefield.\nWhenever Go-Shintai of Life's Origin or another nontoken Shrine enters the battlefield under your control, create a 1/1 colorless Shrine enchantment creature token.",
-          prices =
-            Prices
-              { usd = Just "23.28",
-                usd_foil = Nothing,
-                eur = Just "23.05",
-                eur_foil = Nothing,
-                tix = Nothing
-              }
-        },
-      Card
-        { scryfall_id = fromJust $ fromText "e2539ff7-2b7d-47e3-bd77-3138a6c42d2b",
-          name = "Godsire",
-          set_code = "ALA",
-          collector_number = "170",
-          rarity = "mythic",
-          color_identity = "WGR",
-          oracle_text = Just "Vigilance\n{T}: Create an 8/8 Beast creature token that's red, green, and white.",
-          prices =
-            Prices
-              { usd = Just "7.22",
-                usd_foil = Just "16.56",
-                eur = Just "4.00",
-                eur_foil = Just "13.95",
-                tix = Just "0.02"
-              }
-        }
-    ]
+searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Handler [Card]
+searchCards dbFile q sortBy inCollection =
+  liftIO $
+    withConnection dbFile $ \conn ->
+      queryNamed
+        conn
+        (toQuery query)
+        (selectParameters query)
+  where
+    baseQuery =
+      selectSimple
+        [ "cards.scryfall_id",
+          "cards.name",
+          "cards.set_code",
+          "cards.collector_number",
+          "cards.rarity",
+          "cards.color_identity",
+          "cards.oracle_text",
+          "card_prices.usd",
+          "card_prices.usd_foil",
+          "card_prices.eur",
+          "card_prices.eur_foil",
+          "card_prices.tix"
+        ]
+        ["cards"]
+        <> join
+          [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
+          [sql|CASE WHEN length(cards.color_identity) > 0 THEN '0'
+             ELSE cards.color_identity END ASC|]
+        <> orderBy "cards.name ASC"
+        <> 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)"
+          ]
+    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

@@ -0,0 +1,56 @@
+module Search where
+
+import qualified Data.Char as C
+import qualified Data.Set as Set
+import qualified Data.Text as T
+
+newtype Search = Search [Criteria] deriving (Show)
+
+data Criteria
+  = NameContains T.Text
+  | ExpansionCodeIs T.Text
+  | CardTypeContains T.Text
+  | OracleTextContains T.Text
+  | ColorIdentityIs Colors
+  | ColorIdentityGTE Colors
+  | ColorIdentityLTE Colors
+  | RarityIs Rarity
+  | RarityGTE Rarity
+  | RarityLTE Rarity
+  deriving (Show)
+
+data Color
+  = Colorless
+  | White
+  | Blue
+  | Black
+  | Green
+  | Red
+  deriving (Eq, Ord)
+
+instance Show Color where
+  show White = "W"
+  show Blue = "U"
+  show Black = "B"
+  show Green = "G"
+  show Red = "R"
+
+newtype Colors
+  = Colors (Set.Set Color)
+
+instance Show Colors where
+  show (Colors xs) =
+    mconcat
+      [ "{",
+        mconcat $
+          map show $
+            Set.elems xs,
+        "}"
+      ]
+
+data Rarity
+  = Common
+  | Uncommon
+  | Rare
+  | Mythic
+  deriving (Eq, Ord, Show)

src/SearchParser.hs

@@ -1,65 +1,15 @@
-module Search
-  ( Search.parse,
+module SearchParser
+  ( parseQuery,
   )
 where
 
-import qualified Data.Char as C
+import qualified Control.Monad as Text.Parsec
 import qualified Data.Set as Set
 import qualified Data.Text as T
+import Search
 import Text.Parsec
 import Text.Parsec.Text (Parser)
 
-data Search = Search [Criteria] deriving (Show)
-
-data Criteria
-  = NameContains T.Text
-  | ExpansionCodeIs T.Text
-  | CardTypeContains T.Text
-  | OracleTextContains T.Text
-  | ColorIdentityIs Colors
-  | ColorIdentityGTE Colors
-  | ColorIdentityLTE Colors
-  | RarityIs Rarity
-  | RarityGTE Rarity
-  | RarityLTE Rarity
-  deriving (Show)
-
-data Color
-  = Colorless
-  | White
-  | Black
-  | Blue
-  | Green
-  | Red
-  deriving (Eq, Ord)
-
-instance Show Color where
-  show White = "W"
-  show Black = "B"
-  show Blue = "U"
-  show Green = "G"
-  show Red = "R"
-
-newtype Colors
-  = Colors (Set.Set Color)
-
-instance Show Colors where
-  show (Colors xs) =
-    mconcat
-      [ "{",
-        mconcat $
-          map show $
-            Set.elems xs,
-        "}"
-      ]
-
-data Rarity
-  = Common
-  | Uncommon
-  | Rare
-  | Mythic
-  deriving (Eq, Ord, Show)
-
 literal :: Parser T.Text
 literal = bareLiteral <|> quotedLiteral
   where
@@ -76,21 +26,26 @@ literal = bareLiteral <|> quotedLiteral
 color :: Parser Color
 color = do
   c <- oneOf "wubgr"
-  return $ case c of
-    'w' -> White
-    'u' -> Blue
-    'b' -> Black
-    'g' -> Green
-    'r' -> Red
+  case c of
+    'w' -> return White
+    'u' -> return Blue
+    'b' -> return Black
+    'g' -> return Green
+    'r' -> return Red
+    _ -> parserFail "Invalid color"
 
 rarity :: Parser Rarity
-rarity = do
-  c <- oneOf "curm"
-  return $ case c of
-    'c' -> Common
-    'u' -> Uncommon
-    'r' -> Rare
-    'm' -> Mythic
+rarity =
+  choice
+    [ rarity' Common "common",
+      rarity' Uncommon "uncommon",
+      rarity' Rare "rare",
+      rarity' Mythic "mythic"
+    ]
+  where
+    rarity' :: Rarity -> String -> Parser Rarity
+    rarity' constructor name =
+      choice [try (string name), try (string [head name])] >> return constructor
 
 colors :: Parser Colors
 colors =
@@ -140,11 +95,11 @@ criterion =
   choice
     [ ColorIdentityIs <$> keywords ["c", "color"] ":" colors,
       ColorIdentityLTE <$> keywords ["c", "color"] "<=" colors,
-      ColorIdentityGTE <$> keywords ["c", "color"] ">" colors,
+      ColorIdentityGTE <$> keywords ["c", "color"] ">=" colors,
       RarityIs <$> keywords ["r", "rarity"] ":" rarity,
       RarityLTE <$> keywords ["r", "rarity"] "<=" rarity,
-      RarityGTE <$> keywords ["r", "rarity"] ">" rarity,
-      ExpansionCodeIs <$> keywords ["s", "set"] ":" literal,
+      RarityGTE <$> keywords ["r", "rarity"] ">=" rarity,
+      ExpansionCodeIs <$> keywords ["s", "set", "e", "expansion"] ":" literal,
       CardTypeContains <$> keywords ["t", "type"] ":" literal,
       OracleTextContains <$> keywords ["o", "oracle"] ":" literal,
       NameContains <$> literal
@@ -163,5 +118,5 @@ search = do
   criteria <- spaces >> sepEndBy criterion spaces
   return $ Search criteria
 
-parse :: T.Text -> Either ParseError Search
-parse query = Text.Parsec.parse search "search" query
+parseQuery :: T.Text -> Either ParseError Search
+parseQuery = Text.Parsec.parse search "search"

src/Select.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Select
+  ( Select,
+    toQuery,
+    selectSimple,
+    selectWhere,
+    selectParameters,
+    column,
+    table,
+    join,
+    where_,
+    whereNamedParam,
+    orderBy,
+    limit,
+    limitOffset,
+    parameter,
+    sqlJoin,
+  )
+where
+
+import Control.Monad (unless)
+import Data.List
+import Data.Map
+import Data.Maybe
+import Data.String
+import Data.Text
+import Database.SQLite.Simple
+import Database.SQLite.Simple.Ok
+import Search
+
+data Select a = Select
+  { selectColumns :: [a],
+    selectTables :: [a],
+    selectJoins :: [a],
+    selectCriteria :: [a],
+    selectOrdering :: [a],
+    selectLimit :: Maybe Int,
+    selectOffset :: Maybe Int,
+    selectParameters :: [NamedParam]
+  }
+
+instance Semigroup (Select a) where
+  (<>) a b =
+    Select
+      (selectColumns a <> selectColumns b)
+      (selectTables a <> selectTables b)
+      (selectJoins a <> selectJoins b)
+      (selectCriteria a <> selectCriteria b)
+      (selectOrdering a <> selectOrdering a)
+      (pickLast (selectLimit a) (selectLimit b))
+      (pickLast (selectOffset a) (selectOffset b))
+      (selectParameters a <> selectParameters b)
+    where
+      pickLast _ (Just b) = Just b
+      pickLast a Nothing = a
+
+instance Monoid (Select a) where
+  mempty =
+    Select
+      { selectColumns = [],
+        selectTables = [],
+        selectJoins = [],
+        selectCriteria = [],
+        selectOrdering = [],
+        selectLimit = Nothing,
+        selectOffset = Nothing,
+        selectParameters = []
+      }
+
+toQuery :: (Monoid a, Data.String.IsString a) => Select a -> a
+toQuery select =
+  sqlJoin
+    " "
+    $ [ "SELECT",
+        sqlColumns,
+        "FROM",
+        sqlTables
+      ]
+      <> catMaybes
+        [ sqlJoins,
+          sqlWhere,
+          sqlOrdering,
+          sqlLimitOffset
+        ]
+  where
+    sqlColumns = sqlJoin ", " $ selectColumns select
+    sqlTables = sqlJoin ", " $ selectTables select
+    sqlJoins = case selectJoins select of
+      [] -> Nothing
+      xs -> Just $ sqlJoin " " $ ["JOIN " <> x | x <- xs]
+    sqlWhere = case selectCriteria select of
+      [] -> Nothing
+      xs -> Just $ "WHERE " <> sqlJoin " AND " xs
+    sqlOrdering = case selectOrdering select of
+      [] -> Nothing
+      xs -> Just $ "ORDER BY " <> sqlJoin ", " xs
+    sqlLimitOffset = case (selectLimit select, selectOffset select) of
+      (Just l, Just o) -> Just "LIMIT :__limit, :__offset"
+      (Just l, Nothing) -> Just "LIMIT :__limit"
+      _ -> Nothing
+
+sqlJoin :: (Monoid a, Data.String.IsString a) => a -> [a] -> a
+sqlJoin joiner snippets =
+  mconcat $ Data.List.intercalate [joiner] [[s] | s <- snippets]
+
+selectSimple columns tables =
+  mempty
+    { selectColumns = columns,
+      selectTables = tables
+    }
+
+selectWhere columns tables criteria =
+  mempty
+    { selectColumns = columns,
+      selectTables = tables,
+      selectCriteria = criteria
+    }
+
+column x = mempty {selectColumns = [x]}
+
+table x = mempty {selectTables = [x]}
+
+where_ x = mempty {selectCriteria = [x]}
+
+whereNamedParam column operator paramName value =
+  mempty
+    { selectCriteria = [sqlJoin " " [column, operator, Query paramName]],
+      selectParameters = [paramName := value]
+    }
+
+join x = mempty {selectJoins = [x]}
+
+orderBy x = mempty {selectOrdering = [x]}
+
+limit x =
+  mempty
+    { selectLimit = Just x,
+      selectParameters = [":__limit" := x]
+    }
+
+limitOffset x y =
+  mempty
+    { selectLimit = Just x,
+      selectOffset = Just y,
+      selectParameters = [":__limit" := x, ":__offset" := y]
+    }
+
+parameter name value = mempty {selectParameters = [name := value]}

test/AppSpec.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module AppSpec (spec) where
+
+import Lib (app)
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = with (return $ app "tutor.db") $ do
+  describe "GET /search" $ do
+    it "responds with 200" $ do
+      get "/search" `shouldRespondWith` 200

test/SearchParserSpec.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SearchParserSpec (spec) where
+
+import Data.Text
+import SearchParser (parseQuery)
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "Search parsing" $ do
+    it "matches unquoted text as a name search" $ do
+      parseSearch "foo" `shouldBe` "Right (Search [NameContains \"foo\"])"
+    it "ignores leading and trailing whitespace" $ do
+      parseSearch "  foo  " `shouldBe` "Right (Search [NameContains \"foo\"])"
+    it "treats separate unquoted words as separate name filters" $ do
+      parseSearch "foo bar" `shouldBe` "Right (Search [NameContains \"foo\",NameContains \"bar\"])"
+    it "treats double-quoted phrases as single name filters" $ do
+      parseSearch "\"foo bar\"" `shouldBe` "Right (Search [NameContains \"foo bar\"])"
+    describe "Single colors" $ do
+      it "handles color:white" $ do
+        parseSearch "color:white" `shouldBe` "Right (Search [ColorIdentityIs {W}])"
+      it "handles color:black" $ do
+        parseSearch "color:black" `shouldBe` "Right (Search [ColorIdentityIs {B}])"
+      it "handles color:blue" $ do
+        parseSearch "color:blue" `shouldBe` "Right (Search [ColorIdentityIs {U}])"
+      it "handles color:green" $ do
+        parseSearch "color:green" `shouldBe` "Right (Search [ColorIdentityIs {G}])"
+      it "handles color:red" $ do
+        parseSearch "color:red" `shouldBe` "Right (Search [ColorIdentityIs {R}])"
+      it "handles c:white" $ do
+        parseSearch "c:white" `shouldBe` "Right (Search [ColorIdentityIs {W}])"
+      it "handles c:black" $ do
+        parseSearch "c:black" `shouldBe` "Right (Search [ColorIdentityIs {B}])"
+      it "handles c:blue" $ do
+        parseSearch "c:blue" `shouldBe` "Right (Search [ColorIdentityIs {U}])"
+      it "handles c:green" $ do
+        parseSearch "c:green" `shouldBe` "Right (Search [ColorIdentityIs {G}])"
+      it "handles c:red" $ do
+        parseSearch "c:red" `shouldBe` "Right (Search [ColorIdentityIs {R}])"
+    describe "Ravnican guilds" $ do
+      it "handles color:boros" $ do
+        parseSearch "color:boros" `shouldBe` "Right (Search [ColorIdentityIs {WR}])"
+      it "handles c:boros" $ do
+        parseSearch "c:boros" `shouldBe` "Right (Search [ColorIdentityIs {WR}])"
+      it "handles color:golgari" $ do
+        parseSearch "color:golgari" `shouldBe` "Right (Search [ColorIdentityIs {BG}])"
+      it "handles c:golgari" $ do
+        parseSearch "c:golgari" `shouldBe` "Right (Search [ColorIdentityIs {BG}])"
+      it "handles color:selesnya" $ do
+        parseSearch "color:selesnya" `shouldBe` "Right (Search [ColorIdentityIs {WG}])"
+      it "handles c:selesnya" $ do
+        parseSearch "c:selesnya" `shouldBe` "Right (Search [ColorIdentityIs {WG}])"
+      it "handles color:dimir" $ do
+        parseSearch "color:dimir" `shouldBe` "Right (Search [ColorIdentityIs {BU}])"
+      it "handles c:dimir" $ do
+        parseSearch "c:dimir" `shouldBe` "Right (Search [ColorIdentityIs {BU}])"
+      it "handles color:orzhov" $ do
+        parseSearch "color:orzhov" `shouldBe` "Right (Search [ColorIdentityIs {WB}])"
+      it "handles c:orzhov" $ do
+        parseSearch "c:orzhov" `shouldBe` "Right (Search [ColorIdentityIs {WB}])"
+      it "handles color:izzet" $ do
+        parseSearch "color:izzet" `shouldBe` "Right (Search [ColorIdentityIs {UR}])"
+      it "handles c:izzet" $ do
+        parseSearch "c:izzet" `shouldBe` "Right (Search [ColorIdentityIs {UR}])"
+      it "handles color:gruul" $ do
+        parseSearch "color:gruul" `shouldBe` "Right (Search [ColorIdentityIs {GR}])"
+      it "handles c:gruul" $ do
+        parseSearch "c:gruul" `shouldBe` "Right (Search [ColorIdentityIs {GR}])"
+      it "handles color:azorius" $ do
+        parseSearch "color:azorius" `shouldBe` "Right (Search [ColorIdentityIs {WU}])"
+      it "handles c:azorius" $ do
+        parseSearch "c:azorius" `shouldBe` "Right (Search [ColorIdentityIs {WU}])"
+      it "handles color:rakdos" $ do
+        parseSearch "color:rakdos" `shouldBe` "Right (Search [ColorIdentityIs {BR}])"
+      it "handles c:rakdos" $ do
+        parseSearch "c:rakdos" `shouldBe` "Right (Search [ColorIdentityIs {BR}])"
+      it "handles color:simic" $ do
+        parseSearch "color:simic" `shouldBe` "Right (Search [ColorIdentityIs {UG}])"
+      it "handles c:simic" $ do
+        parseSearch "c:simic" `shouldBe` "Right (Search [ColorIdentityIs {UG}])"
+    describe "Alaran shards" $ do
+      it "handles color:bant" $ do
+        parseSearch "color:bant" `shouldBe` "Right (Search [ColorIdentityIs {WUG}])"
+      it "handles c:bant" $ do
+        parseSearch "c:bant" `shouldBe` "Right (Search [ColorIdentityIs {WUG}])"
+      it "handles color:esper" $ do
+        parseSearch "color:esper" `shouldBe` "Right (Search [ColorIdentityIs {WBU}])"
+      it "handles c:esper" $ do
+        parseSearch "c:esper" `shouldBe` "Right (Search [ColorIdentityIs {WBU}])"
+      it "handles color:grixis" $ do
+        parseSearch "color:grixis" `shouldBe` "Right (Search [ColorIdentityIs {BUR}])"
+      it "handles c:grixis" $ do
+        parseSearch "c:grixis" `shouldBe` "Right (Search [ColorIdentityIs {BUR}])"
+      it "handles color:jund" $ do
+        parseSearch "color:jund" `shouldBe` "Right (Search [ColorIdentityIs {BGR}])"
+      it "handles c:jund" $ do
+        parseSearch "c:jund" `shouldBe` "Right (Search [ColorIdentityIs {BGR}])"
+      it "handles color:naya" $ do
+        parseSearch "color:naya" `shouldBe` "Right (Search [ColorIdentityIs {WGR}])"
+      it "handles c:naya" $ do
+        parseSearch "c:naya" `shouldBe` "Right (Search [ColorIdentityIs {WGR}])"
+    describe "Tarkirian wedges" $ do
+      it "handles color:abzan" $ do
+        parseSearch "color:abzan" `shouldBe` "Right (Search [ColorIdentityIs {WBG}])"
+      it "handles c:abzan" $ do
+        parseSearch "c:abzan" `shouldBe` "Right (Search [ColorIdentityIs {WBG}])"
+      it "handles color:jeskai" $ do
+        parseSearch "color:jeskai" `shouldBe` "Right (Search [ColorIdentityIs {WUR}])"
+      it "handles c:jeskai" $ do
+        parseSearch "c:jeskai" `shouldBe` "Right (Search [ColorIdentityIs {WUR}])"
+      it "handles color:sultai" $ do
+        parseSearch "color:sultai" `shouldBe` "Right (Search [ColorIdentityIs {BUG}])"
+      it "handles c:sultai" $ do
+        parseSearch "c:sultai" `shouldBe` "Right (Search [ColorIdentityIs {BUG}])"
+      it "handles color:mardu" $ do
+        parseSearch "color:mardu" `shouldBe` "Right (Search [ColorIdentityIs {WBR}])"
+      it "handles c:mardu" $ do
+        parseSearch "c:mardu" `shouldBe` "Right (Search [ColorIdentityIs {WBR}])"
+      it "handles color:temur" $ do
+        parseSearch "color:temur" `shouldBe` "Right (Search [ColorIdentityIs {UGR}])"
+      it "handles c:temur" $ do
+        parseSearch "c:temur" `shouldBe` "Right (Search [ColorIdentityIs {UGR}])"
+    describe "Multicolor" $ do
+      it "handles color:wbugr" $ do
+        parseSearch "color:wbugr" `shouldBe` "Right (Search [ColorIdentityIs {WBUGR}])"
+      it "handles c:wbugr" $ do
+        parseSearch "c:wbugr" `shouldBe` "Right (Search [ColorIdentityIs {WBUGR}])"
+      it "handles a lack of colors" $ do
+        parseSearch "c:" `shouldBe` "Right (Search [ColorIdentityIs {}])"
+    describe "Color ranges" $ do
+      it "handles color<=gr" $ do
+        parseSearch "color<=gr" `shouldBe` "Right (Search [ColorIdentityLTE {GR}])"
+      it "handles c<=gr" $ do
+        parseSearch "c<=gr" `shouldBe` "Right (Search [ColorIdentityLTE {GR}])"
+      it "handles color>=gr" $ do
+        parseSearch "color>=gr" `shouldBe` "Right (Search [ColorIdentityGTE {GR}])"
+      it "handles c>=gr" $ do
+        parseSearch "c>=gr" `shouldBe` "Right (Search [ColorIdentityGTE {GR}])"
+    describe "Rarities" $ do
+      it "handles rarity:common" $ do
+        parseSearch "rarity:common" `shouldBe` "Right (Search [RarityIs Common])"
+      it "handles rarity:c" $ do
+        parseSearch "rarity:c" `shouldBe` "Right (Search [RarityIs Common])"
+      it "handles rarity:uncommon" $ do
+        parseSearch "rarity:uncommon" `shouldBe` "Right (Search [RarityIs Uncommon])"
+      it "handles rarity:u" $ do
+        parseSearch "rarity:u" `shouldBe` "Right (Search [RarityIs Uncommon])"
+      it "handles rarity:rare" $ do
+        parseSearch "rarity:rare" `shouldBe` "Right (Search [RarityIs Rare])"
+      it "handles rarity:r" $ do
+        parseSearch "rarity:r" `shouldBe` "Right (Search [RarityIs Rare])"
+      it "handles rarity:mythic" $ do
+        parseSearch "rarity:mythic" `shouldBe` "Right (Search [RarityIs Mythic])"
+      it "handles rarity:m" $ do
+        parseSearch "rarity:m" `shouldBe` "Right (Search [RarityIs Mythic])"
+    describe "Rarity ranges" $ do
+      it "handles rarity<=rare" $ do
+        parseSearch "rarity<=rare" `shouldBe` "Right (Search [RarityLTE Rare])"
+      it "handles rarity<=r" $ do
+        parseSearch "rarity<=r" `shouldBe` "Right (Search [RarityLTE Rare])"
+      it "handles rarity>=rare" $ do
+        parseSearch "rarity>=rare" `shouldBe` "Right (Search [RarityGTE Rare])"
+      it "handles rarity>=r" $ do
+        parseSearch "rarity>=r" `shouldBe` "Right (Search [RarityGTE Rare])"
+    describe "Expansion codes with unquoted text" $ do
+      it "handles set:roe" $ do
+        parseSearch "set:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+      it "handles s:roe" $ do
+        parseSearch "s:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+      it "handles expansion:roe" $ do
+        parseSearch "expansion:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+      it "handles e:roe" $ do
+        parseSearch "e:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+    describe "Card types with unquoted text" $ do
+      it "handles type:legendary" $ do
+        parseSearch "type:legendary" `shouldBe` "Right (Search [CardTypeContains \"legendary\"])"
+      it "handles t:legendary" $ do
+        parseSearch "t:legendary" `shouldBe` "Right (Search [CardTypeContains \"legendary\"])"
+    describe "Card types with double-quoted text" $ do
+      it "handles type:\"legendary creature\"" $ do
+        parseSearch "type:\"legendary creature\"" `shouldBe` "Right (Search [CardTypeContains \"legendary creature\"])"
+      it "handles t:\"legendary creature\"" $ do
+        parseSearch "t:\"legendary creature\"" `shouldBe` "Right (Search [CardTypeContains \"legendary creature\"])"
+    describe "Oracle text with unquoted text" $ do
+      it "handles oracle:destroy" $ do
+        parseSearch "oracle:destroy" `shouldBe` "Right (Search [OracleTextContains \"destroy\"])"
+      it "handles o:destroy" $ do
+        parseSearch "o:destroy" `shouldBe` "Right (Search [OracleTextContains \"destroy\"])"
+    describe "Oracle text with double-quoted text" $ do
+      it "handles oracle:\"destroy creature\"" $ do
+        parseSearch "oracle:\"destroy creature\"" `shouldBe` "Right (Search [OracleTextContains \"destroy creature\"])"
+      it "handles o:\"destroy creature\"" $ do
+        parseSearch "o:\"destroy creature\"" `shouldBe` "Right (Search [OracleTextContains \"destroy creature\"])"
+  where
+    parseSearch :: Text -> Text
+    parseSearch = pack . show . parseQuery

test/Spec.hs

@@ -1,71 +1 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Main (main) where
-
-import Lib (app)
-import Test.Hspec
-import Test.Hspec.Wai
-import Test.Hspec.Wai.JSON
-
-main :: IO ()
-main = hspec spec
-
-spec :: Spec
-spec = with (return app) $ do
-  describe "GET /search" $ do
-    it "responds with 200" $ do
-      get "/search" `shouldRespondWith` 200
-    it "responds with [Card]" $ do
-      let cards =
-            [json|[
-                    {
-                      "scryfall_id": "f6cd7465-9dd0-473c-ac5e-dd9e2f22f5f6",
-                      "name": "Esika, God of the Tree // The Prismatic Bridge",
-                      "set_code": "KHM",
-                      "collector_number": "168",
-                      "rarity": "mythic",
-                      "color_identity": "WUBGR",
-                      "oracle_text": null,
-                      "prices": {
-                        "usd": "9.07",
-                        "usd_foil": "10.77",
-                        "eur": "7.79",
-                        "eur_foil": "12.27",
-                        "tix": "1.08"
-                      }
-                    },
-                    {
-                      "scryfall_id": "d761ff73-0717-4ee4-996b-f5547bcf9b2f",
-                      "name": "Go-Shintai of Life's Origin",
-                      "set_code": "NEC",
-                      "collector_number": "66",
-                      "rarity": "mythic",
-                      "color_identity": "WUBGR",
-                      "oracle_text": "{W}{U}{B}{R}{G}, {T}: Return target enchantment card from your graveyard to the battlefield.\nWhenever Go-Shintai of Life's Origin or another nontoken Shrine enters the battlefield under your control, create a 1/1 colorless Shrine enchantment creature token.",
-                      "prices": {
-                        "usd": "23.28",
-                        "usd_foil": null,
-                        "eur": "23.05",
-                        "eur_foil": null,
-                        "tix": null
-                      }
-                    },
-                    {
-                      "scryfall_id": "e2539ff7-2b7d-47e3-bd77-3138a6c42d2b",
-                      "name": "Godsire",
-                      "set_code": "ALA",
-                      "collector_number": "170",
-                      "rarity": "mythic",
-                      "color_identity": "WGR",
-                      "oracle_text": "Vigilance\n{T}: Create an 8/8 Beast creature token that's red, green, and white.",
-                      "prices": {
-                        "usd": "7.22",
-                        "usd_foil": "16.56",
-                        "eur": "4.00",
-                        "eur_foil": "13.95",
-                        "tix": "0.02"
-                      }
-                    }
-                  ]|]
-      get "/search" `shouldRespondWith` cards
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

tutor.cabal

@@ -24,6 +24,9 @@ source-repository head
 library
   exposed-modules:
       Lib
+      Search
+      SearchParser
+      Select
   other-modules:
       Paths_tutor
   hs-source-dirs:
@@ -38,6 +41,7 @@ library
     , parsec-extra
     , servant-openapi3
     , servant-server
+    , sqlite-simple
     , text
     , uuid
     , wai
@@ -62,6 +66,7 @@ executable tutor-exe
     , parsec-extra
     , servant-openapi3
     , servant-server
+    , sqlite-simple
     , text
     , tutor
     , uuid
@@ -74,6 +79,8 @@ test-suite tutor-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      AppSpec
+      SearchParserSpec
       Paths_tutor
   hs-source-dirs:
       test
@@ -91,6 +98,7 @@ test-suite tutor-test
     , parsec-extra
     , servant-openapi3
     , servant-server
+    , sqlite-simple
     , text
     , tutor
     , uuid