Add Pagination

Tests updated to use a test database.

.dockerignore

@@ -1,3 +1,4 @@
+.git
 .DS_Store
 .idea
 *.log
@@ -13,3 +14,7 @@ www/elm-stuff
 www/node_modules
 www/package-lock.json
 www/public/elm.js
+
+.stack-work/
+test.db
+tutor.db

.gitignore

@@ -8,3 +8,8 @@ tmp/
 *.egg
 build
 htmlcov
+
+.stack-work/
+tutor.cabal
+test.db
+tutor.db

Dockerfile

@@ -1,33 +1,28 @@
-FROM python:3.9.6-alpine3.14 as base
+FROM haskell:9.0.2-slim as base
 
-WORKDIR /app
+FROM base as dependencies
 
-FROM base as builder
+RUN mkdir /build
+WORKDIR /build
+COPY stack.yaml package.yaml stack.yaml.lock /build/
+RUN stack build --system-ghc --only-dependencies
 
-ENV PIP_DEFAULT_TIMEOUT=100 \
-    PIP_DISABLE_PIP_VERSION_CHECK=1 \
-    PIP_NO_CACHE_DIR=1 \
-    POETRY_VERSION=1.1.4
+FROM base as build
 
-RUN apk add --no-cache gcc libffi-dev musl-dev openssl-dev rust cargo
-RUN pip install "poetry==$POETRY_VERSION"
-RUN python -m venv /venv
-
-COPY pyproject.toml poetry.lock ./
-RUN poetry export -f requirements.txt | /venv/bin/pip install -r /dev/stdin
-
-COPY . .
-RUN poetry build && /venv/bin/pip install dist/*.whl
+COPY --from=dependencies /root/.stack /root/.stack
+COPY . /build/
+WORKDIR /build
+RUN stack build --system-ghc
+RUN mv "$(stack path --local-install-root --system-ghc)/bin" /build/bin
 
 FROM base as frontend
 
-RUN apk add --no-cache curl
 COPY www /www
-RUN curl -sL --output elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz \
-    && gunzip elm.gz \
-    && chmod +x elm \
+RUN curl -sL --output /bin/elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz \
+    && gunzip /bin/elm.gz \
+    && chmod +x /bin/elm \
     && cd /www \
-    && /app/elm make /www/src/App.elm --output /www/public/elm.js
+    && /bin/elm make /www/src/App.elm --output /www/public/elm.js
 
 FROM base as final
 
@@ -37,9 +32,6 @@ ENV TUTOR_PORT=8888 \
     TUTOR_DATABASE=/tutor.db \
     TUTOR_STATIC=/www
 
-RUN apk add sqlite
-COPY --from=builder /venv /venv
+COPY --from=build /build/bin /app
 COPY --from=frontend /www/public /www
-COPY docker-entrypoint.sh tables.sql ./
-ENTRYPOINT ["./docker-entrypoint.sh"]
-CMD ["server"]
+ENTRYPOINT ["/app/tutor-exe"]

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,10 @@
+module Main where
+
+import System.Envy (decodeWithDefaults)
+import Tutor
+import Tutor.Config
+
+main :: IO ()
+main = do
+  config <- decodeWithDefaults defaultConfig :: IO Config
+  startApp config

package.yaml

@@ -0,0 +1,71 @@
+name:                tutor
+version:             0.1.0.0
+github:              "githubuser/tutor"
+license:             BSD3
+author:              "Author name here"
+maintainer:          "example@example.com"
+copyright:           "2022 Author name here"
+
+extra-source-files:
+- README.org
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/githubuser/tutor#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- aeson
+- containers
+- envy
+- lens
+- network-uri
+- openapi3
+- parsec
+- parsec-extra
+- servant-openapi3
+- servant-server
+- sqlite-simple
+- text
+- uuid
+- wai
+- wai-logger
+- warp
+
+library:
+  source-dirs: src
+
+executables:
+  tutor-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Wall
+    dependencies:
+    - base
+    - tutor
+
+tests:
+  tutor-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Wall
+    dependencies:
+    - base
+    - tutor
+    - hspec
+    - hspec-wai
+    - hspec-wai-json
+    - aeson

src/Tutor.hs

@@ -0,0 +1,17 @@
+module Tutor (startApp) where
+
+import Network.Wai.Handler.Warp
+import Network.Wai.Logger
+import Servant (serve)
+import Tutor.Api (app)
+import Tutor.Config
+import Tutor.Database (initDb)
+
+startApp :: Config -> IO ()
+startApp config = do
+  initDb (tutorDatabase config)
+  withStdoutLogger $
+    \logger ->
+      runSettings
+        (setPort (tutorPort config) $ setLogger logger $ defaultSettings)
+        (app config)

src/Tutor/Api.hs

@@ -0,0 +1,262 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Tutor.Api (app) where
+
+import Control.Lens
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (FromJSON, ToJSON)
+import Data.OpenApi
+  ( HasDescription (description),
+    HasInfo (info),
+    HasLicense (license),
+    HasTitle (title),
+    HasUrl (url),
+    HasVersion (version),
+    OpenApi,
+    ToSchema,
+    URL (URL),
+  )
+import qualified Data.Text as T
+import Data.Typeable (Typeable)
+import Data.Version (showVersion)
+import GHC.Generics (Generic)
+import Network.URI
+import qualified Paths_tutor as PT
+import Servant
+import Servant.OpenApi (HasOpenApi (toOpenApi))
+import qualified Tutor.Pagination as Pagination
+import Tutor.Card
+import Tutor.Config
+import Tutor.Database
+import Data.Maybe (fromMaybe)
+import qualified Data.Text.Lazy.Lens as T
+
+data Status = Status
+  { apiVersion :: T.Text,
+    config :: Config
+  }
+  deriving (Generic, Typeable)
+
+instance FromJSON Config
+
+instance ToJSON Config
+
+instance ToSchema Config
+
+instance FromJSON Status
+
+instance ToJSON Status
+
+instance ToSchema Status
+
+instance FromJSON Prices
+
+instance ToJSON Prices
+
+instance FromJSON Card
+
+instance ToJSON Card
+
+instance ToSchema Prices
+
+instance ToSchema Card
+
+type GetStatus =
+  Summary "Get API Status"
+    :> Description "Get the current running API version."
+    :> "api"
+    :> "status"
+    :> Get '[JSON] Status
+
+type LinkHeaders =
+  '[ Header "Link" T.Text
+   , Header "Link" T.Text
+   , Header "Link" T.Text]
+
+type SearchCards =
+  Summary "Search for cards in a collection"
+    :> Description
+         "Text in the query string will be used to filter cards having that text in their \n\
+         \name. Additionally, the keyword expressions below can be used to search for \n\
+         \cards with certain properties. \n\
+         \ \n\
+         \ \n\
+         \### Examples \n\
+         \ \n\
+         \`bolt` \n\
+         \: Find all cards with \"bolt\" in the name \n\
+         \ \n\
+         \`\"God of\"` \n\
+         \: Find all cards with \"God of\" in the name \n\
+         \ \n\
+         \`t:legendary t:creature c:jund` \n\
+         \: Find all legendary creatures with a color \n\
+         \    identity of red/blue/green \n\
+         \ \n\
+         \`color<=ubg` \n\
+         \: Find all spells that are blue, black, green, or any \n\
+         \    combination thereof. \n\
+         \ \n\
+         \`color:red set:stx rarity>=rare` \n\
+         \: Find all red cards in Strixhaven that are \n\
+         \    rare or mythic \n\
+         \ \n\
+         \`t:enchantment o:\"enters the battlefield\"` \n\
+         \: Find all enchantments with ETB \n\
+         \    effects \n\
+         \ \n\
+         \ \n\
+         \### Keywords \n\
+         \ \n\
+         \ \n\
+         \#### Colors \n\
+         \ \n\
+         \Keywords \n\
+         \: `c`, `color` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches), `>=` (greater than or equal to), `<=` (less than \n\
+         \    or equal to) \n\
+         \ \n\
+         \Matches cards of the chosen color or colors. \n\
+         \ \n\
+         \Single colors \n\
+         \: `w` or `white`, `u` or `blue`, `b` or `black, =g` or `green`, `r` or `red` \n\
+         \ \n\
+         \Any combination of abbreviated single colors \n\
+         \: e.g.: `rg`, `uw`, or `wubgr` \n\
+         \ \n\
+         \Ravnican guilds \n\
+         \: `boros` (white/red), `golgari` (green/black), `selesnya` \n\
+         \    (green/white), `dimir` (blue/black), `orzhov` (white/black), `izzet` \n\
+         \    (blue/red), `gruul` (red/green), `azorius` (white/blue), `rakdos` (black/red), \n\
+         \    `simic` (green/blue) \n\
+         \ \n\
+         \Alaran shards \n\
+         \: `bant` (white/green/blue), `esper` (blue/white/black), \n\
+         \    `grixis` (black/blue/red), `jund` (red/blue/green), `naya` (green/red/white) \n\
+         \ \n\
+         \Tarkirian wedges \n\
+         \: `abzan` (white/black/green), `jeskai` (white/blue/red), \n\
+         \    `sultai` (blue/black/green), `mardu` (white/black/red), `temur` \n\
+         \    (blue/red/green) \n\
+         \ \n\
+         \ \n\
+         \#### Sets \n\
+         \ \n\
+         \Keywords \n\
+         \: `s`, `set`, `e`, `expansion` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches) \n\
+         \ \n\
+         \ \n\
+         \#### Rarity \n\
+         \ \n\
+         \Keywords \n\
+         \: `r`, `rarity` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches), `>=` (greater than or equal to), `<=` (less than \n\
+         \    or equal to) \n\
+         \ \n\
+         \ \n\
+         \#### Type \n\
+         \ \n\
+         \Keywords \n\
+         \: `t`, `type` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches) \n\
+         \ \n\
+         \ \n\
+         \#### Oracle Text \n\
+         \ \n\
+         \Keywords \n\
+         \: `o`, `oracle` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (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
+    :> QueryParam' '[Description "Pagination limit"] "limit" Int
+    :> QueryParam' '[Description "Pagination offset"] "offset" Int
+    :> Get '[JSON] (Headers LinkHeaders [Card])
+
+type TutorAPI =
+  GetStatus
+    :<|> SearchCards
+
+type DocsAPI =
+  "api" :> "openapi.json" :> Get '[JSON] OpenApi
+
+type ElmAPI = Raw
+
+type API = TutorAPI :<|> DocsAPI :<|> ElmAPI
+
+tutorAPI :: Proxy TutorAPI
+tutorAPI = Proxy
+
+api :: Proxy API
+api = Proxy
+
+openapi :: OpenApi
+openapi =
+  toOpenApi tutorAPI
+    & info . title .~ "Tutor API"
+    & info . version .~ packageVersion
+    & info . description ?~ "An API for searching a Magic: The Gathering card collection."
+    & info . license ?~ ("MIT" & url ?~ URL "http://mit.com")
+
+tutorServer :: Config -> Server TutorAPI
+tutorServer config = status config :<|> searchCards (tutorDatabase config)
+  where
+    searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Maybe Int -> Maybe Int -> Handler (Headers LinkHeaders [Card])
+    searchCards dbFile q sortBy inCollection limit offset = do
+      page <- liftIO $ Tutor.Database.searchCards dbFile q sortBy inCollection pagination
+      return $ headers page (Pagination.items page)
+      where pagination = Pagination.Pagination (fromMaybe 10 limit) (fromMaybe 0 offset)
+            headers page = self . next page . prev page
+            self = addHeader $ link "self" $ uri limit offset
+            next Pagination.Page {Pagination.next = Just p} = addHeader $ link "next" $ uri (Just $ Pagination.limit p) (Just $ Pagination.offset p)
+            next _ = noHeader
+            prev Pagination.Page {Pagination.previous = Just p} = addHeader $ link "prev" $ uri (Just $ Pagination.limit p) (Just $ Pagination.offset p)
+            prev _ = noHeader
+            uri :: Maybe Int -> Maybe Int -> URI
+            uri limit' offset' =
+              -- TODO: Apply the generated relative URI to the requested absolute URI
+              relativeTo
+                (linkURI $ safeLink api (Proxy :: Proxy SearchCards) q sortBy inCollection limit' offset')
+                (configuredBaseURI config)
+            link :: T.Text -> URI -> T.Text
+            link rel uri = T.concat ["<", T.pack $ show uri, ">; rel=\"", rel, "\""]
+
+docsServer :: Server DocsAPI
+docsServer = return openapi
+
+elmServer :: FilePath -> Server ElmAPI
+elmServer = serveDirectoryFileServer
+
+server :: Config -> Server API
+server config = tutorServer config :<|> docsServer :<|> elmServer (tutorStatic config)
+
+packageVersion :: T.Text
+packageVersion = T.pack $ showVersion PT.version
+
+status :: Config -> Handler Status
+status config =
+  return
+    Status
+      { apiVersion = packageVersion,
+        config = config
+      }
+
+app :: Config -> Application
+app config = serve api $ server config

src/Tutor/Card.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Tutor.Card where
+
+import qualified  Data.Text as T
+import GHC.Generics (Generic)
+import Data.Typeable (Typeable)
+import qualified Data.UUID as UUID
+data Prices = Prices
+  { usd :: Maybe T.Text,
+    usd_foil :: Maybe T.Text,
+    eur :: Maybe T.Text,
+    eur_foil :: Maybe T.Text,
+    tix :: Maybe T.Text
+  }
+  deriving (Eq, Show, Generic, Typeable)
+
+
+data Card = Card
+  { scryfall_id :: UUID.UUID,
+    name :: T.Text,
+    set_code :: T.Text,
+    collector_number :: T.Text,
+    rarity :: T.Text,
+    color_identity :: T.Text,
+    oracle_text :: Maybe T.Text,
+    prices :: Prices
+  }
+  deriving (Eq, Show, Generic, Typeable)
+

src/Tutor/Config.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Tutor.Config (Config (..), defaultConfig, configuredBaseURI) where
+
+import GHC.Generics
+import Network.URI
+import System.Envy
+
+data Config = Config
+  { tutorPort :: Int,
+    tutorDatabase :: FilePath,
+    tutorStatic :: FilePath,
+    tutorBaseUrl :: Maybe String
+  }
+  deriving (Generic, Show)
+
+defaultConfig =
+  Config
+    { tutorPort = 8000,
+      tutorDatabase = "tutor.db",
+      tutorStatic = "www/public",
+      tutorBaseUrl = Nothing
+    }
+
+configuredBaseURI :: Config -> URI
+configuredBaseURI config =
+  case tutorBaseUrl config >>= parseURI of
+    Just uri -> uri
+    Nothing -> URI "http:" (Just $ URIAuth "" "localhost" (":" ++ show (tutorPort config))) "/" "" ""
+
+instance FromEnv Config

src/Tutor/Database.hs

@@ -0,0 +1,333 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Tutor.Database (initDb, searchCards) where
+
+import qualified Data.List as List
+import Data.Maybe
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.UUID as UUID
+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 Tutor.Card
+import qualified Tutor.Pagination as Pagination
+import qualified Tutor.Search as Search
+import Tutor.SearchParser
+import Tutor.Select
+  ( Select (..),
+    join,
+    limitOffset,
+    orderBy,
+    parameter,
+    selectSimple,
+    sqlJoin,
+    toQuery,
+    whereNamedParam,
+    where_,
+  )
+
+schema :: [Query]
+schema =
+  [ [sql|
+      CREATE TABLE IF NOT EXISTS `sets` (
+          `set_code` TEXT PRIMARY KEY,
+          `name` TEXT NOT NULL
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `rarities` (
+          `rarity` TEXT PRIMARY KEY,
+          `rarity_ord` INTEGER NOT NULL
+      );
+    |],
+    [sql|
+      DELETE FROM `rarities`;
+    |],
+    [sql|
+      INSERT INTO `rarities` (`rarity`, `rarity_ord`) VALUES
+      ('n/a', 0),
+      ('common', 1),
+      ('uncommon', 2),
+      ('rare', 3),
+      ('special', 4),
+      ('mythic', 5),
+      ('bonus', 6);
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `cards` (
+          `scryfall_id` TEXT PRIMARY KEY,
+          `oracle_id` TEXT,
+          `name` TEXT NOT NULL,
+          `set_code` TEXT,
+          `collector_number` TEXT,
+          `release_date` TEXT,
+          `rarity` TEXT NOT NULL,
+          `color_identity` TEXT NOT NULL,
+          `cmc` TEXT NOT NULL, -- Decimal value
+          `type_line` TEXT NOT NULL,
+          `foil` INTEGER NOT NULL DEFAULT 0,
+          `nonfoil` INTEGER NOT NULL DEFAULT 1,
+          `variation` INTEGER NOT NULL DEFAULT 0,
+          `edhrec_rank` INTEGER,
+          `oracle_text` TEXT,
+          FOREIGN KEY (`set_code`) REFERENCES `sets` (`set_code`),
+          FOREIGN KEY (`rarity`) REFERENCES `rarities` (`rarity`)
+      );
+    |],
+    [sql|
+      CREATE INDEX IF NOT EXISTS `cards_name` ON `cards`(`name` COLLATE nocase);
+    |],
+    [sql|
+      CREATE INDEX IF NOT EXISTS `cards_rarity` ON `cards`(`rarity`);
+    |],
+    [sql|
+      CREATE INDEX IF NOT EXISTS `cards_color_identity` ON `cards`(`color_identity`);
+    |],
+    [sql|
+      CREATE INDEX IF NOT EXISTS `cards_oracle_id` ON `cards` (`oracle_id`);
+    |],
+    [sql|
+      CREATE INDEX IF NOT EXISTS `cards_name` ON `cards` (`name`);
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `copies` (
+          `id` INTEGER PRIMARY KEY AUTOINCREMENT,
+          `collection` TEXT NOT NULL DEFAULT 'Default',
+          `scryfall_id` TEXT,
+          `isFoil` INTEGER NOT NULL DEFAULT 0,
+          `language` TEXT,
+          `condition` TEXT,
+          FOREIGN KEY (`scryfall_id`) REFERENCES `cards`(`scryfall_id`)
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `card_prices` (
+          `scryfall_id` TEXT,
+          `date` TEXT,
+          `usd` TEXT, -- Decimal value
+          `usd_foil` TEXT, -- Decimal value
+          `eur` TEXT, -- Decimal value
+          `eur_foil` TEXT, -- Decimal value
+          `tix` TEXT, -- Decimal value
+          PRIMARY KEY (`scryfall_id`, `date`),
+          FOREIGN KEY (`scryfall_id`) REFERENCES `cards`(`scryfall_id`)
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `legalities` (
+          `scryfall_id` TEXT NOT NULL,
+          `format` TEXT NOT NULL,
+          `legality` TEXT NOT NULL,
+          PRIMARY KEY (`scryfall_id`, `format`),
+          FOREIGN KEY (`scryfall_id`) REFERENCES `cards`(`scryfall_id`)
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `games` (
+          `scryfall_id` TEXT NOT NULL,
+          `game` TEXT NOT NULL, -- 'paper', 'arena', or 'mtgo'
+          PRIMARY KEY (`scryfall_id`, `game`),
+          FOREIGN KEY (`scryfall_id`) REFERENCES `cards`(`scryfall_id`)
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `decks` (
+          `deck_id` INTEGER PRIMARY KEY AUTOINCREMENT,
+          `name` TEXT NOT NULL
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `deck_cards` (
+          `deck_id` INTEGER NOT NULL,
+          `oracle_id` TEXT NOT NULL,
+          `quantity` INTEGER NOT NULL DEFAULT 1,
+          PRIMARY KEY (`deck_id`, `oracle_id`),
+          FOREIGN KEY (`deck_id`) REFERENCES `decks`(`deck_id`)
+      );
+    |],
+    [sql|
+      CREATE TABLE IF NOT EXISTS `vars` (
+          `key` TEXT PRIMARY KEY,
+          `value` TEXT
+      );
+      |]
+  ]
+
+initDb :: FilePath -> IO ()
+initDb dbFile =
+  withConnection dbFile $ \conn ->
+    mapM_ (execute_ conn) schema
+
+instance FromField UUID.UUID where
+  fromField (Field (SQLText txt) _) = Ok $ fromMaybe UUID.nil $ UUID.fromText txt
+  fromField f = returnError ConversionFailed f "need a text"
+
+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
+              }
+        }
+
+searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Pagination.Pagination -> IO (Pagination.Page Card)
+searchCards dbFile q sortBy inCollection pagination =
+  withConnection dbFile $ \conn ->
+    asPage <$> queryNamed
+      conn
+      (toQuery query)
+      (selectParameters query)
+  where
+    limit = Pagination.limit pagination
+    offset = Pagination.offset pagination
+    asPage results =
+      if length results > limit then
+        Pagination.Page prev (Just $ Pagination.Pagination limit (offset + limit)) (take limit results)
+      else
+        Pagination.Page prev Nothing results
+      where
+        prev = if offset > 0 then Just $ Pagination.Pagination limit (max 0 (offset - limit)) else Nothing
+    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)
+        <> limitOffset (1 + Pagination.limit pagination) (Pagination.offset pagination)
+    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.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 -> Search.Criteria -> Select Query
+    fromNamedCriteria param (Search.NameContains txt) =
+      whereNamedParam "cards.name" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (Search.ExpansionCodeIs txt) =
+      whereNamedParam "cards.set_code" "LIKE" param txt
+    fromNamedCriteria param (Search.CardTypeContains txt) =
+      whereNamedParam "cards.type_line" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (Search.OracleTextContains txt) =
+      whereNamedParam "cards.oracle_text" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (Search.ColorIdentityIs colors) =
+      whereNamedParam
+        "cards.color_identity"
+        "LIKE"
+        param
+        (mconcat $ fromColors colors)
+    fromNamedCriteria param (Search.ColorIdentityLTE colors) =
+      if List.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 (Search.ColorIdentityGTE colors) =
+      whereNamedParam
+        "cards.color_identity"
+        "LIKE"
+        param
+        ("%" <> mconcat (fromColors colors) <> "%")
+    fromNamedCriteria param (Search.RarityIs rarity) =
+      whereNamedParam "cards.rarity" "LIKE" param (rarityName rarity)
+    fromNamedCriteria param (Search.RarityLTE rarity) =
+      whereNamedParam "rarities.rarity_ord" "<=" param (rarityValue rarity)
+    fromNamedCriteria param (Search.RarityGTE rarity) =
+      whereNamedParam "rarities.rarity_ord" ">=" param (rarityValue rarity)
+
+    fromColors :: Search.Colors -> [T.Text]
+    fromColors (Search.Colors colors) = map (T.pack . show) (Set.toList colors)
+
+    rarityName :: Search.Rarity -> T.Text
+    rarityName Search.Common = "common"
+    rarityName Search.Uncommon = "uncommon"
+    rarityName Search.Rare = "rare"
+    rarityName Search.Mythic = "mythic"
+
+    rarityValue :: Search.Rarity -> Int
+    rarityValue Search.Common = 1
+    rarityValue Search.Uncommon = 2
+    rarityValue Search.Rare = 3
+    rarityValue Search.Mythic = 5

src/Tutor/Pagination.hs

@@ -0,0 +1,12 @@
+module Tutor.Pagination (Pagination(..), Page(..)) where
+
+data Pagination = Pagination
+  { limit :: Int
+  , offset :: Int
+  }
+
+data Page a = Page
+  { previous :: Maybe Pagination
+  , next :: Maybe Pagination
+  , items :: [a]
+  }

src/Tutor/Search.hs

@@ -0,0 +1,73 @@
+module Tutor.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 (Eq, Show)
+
+data SearchOptions = SearchOptions
+  { inCollection :: Bool,
+    orderBy :: OrderBy
+  }
+
+data OrderBy
+  = Rarity SearchOrder
+  | Price SearchOrder
+
+data SearchOrder
+  = Ascending
+  | Descending
+
+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 (Eq, 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)
+  deriving (Eq)
+
+instance Show Colors where
+  show (Colors xs) =
+    mconcat
+      [ "{",
+        mconcat $
+          map show $
+            Set.elems xs,
+        "}"
+      ]
+
+toColors :: [Color] -> Colors
+toColors = Colors . Set.fromList
+
+data Rarity
+  = Common
+  | Uncommon
+  | Rare
+  | Mythic
+  deriving (Eq, Ord, Show)

src/Tutor/SearchParser.hs

@@ -0,0 +1,122 @@
+module Tutor.SearchParser
+  ( parseQuery,
+  )
+where
+
+import qualified Control.Monad as Text.Parsec
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Text.Parsec
+import Text.Parsec.Text (Parser)
+import Tutor.Search
+
+literal :: Parser T.Text
+literal = bareLiteral <|> quotedLiteral
+  where
+    bareLiteral :: Parser T.Text
+    bareLiteral = do
+      chars <- many1 $ noneOf " \""
+      return $ T.pack chars
+
+    quotedLiteral :: Parser T.Text
+    quotedLiteral = do
+      chars <- between (char '"') (char '"') (many $ noneOf "\"")
+      return $ T.pack chars
+
+color :: Parser Color
+color = do
+  c <- oneOf "wubgr"
+  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 =
+  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 =
+  choice
+    [ -- Single colors
+      colorGroup "white" [White],
+      colorGroup "black" [Black],
+      colorGroup "blue" [Blue],
+      colorGroup "green" [Green],
+      colorGroup "red" [Red],
+      -- Ravnican Guilds
+      colorGroup "boros" [Red, White],
+      colorGroup "golgari" [Green, Black],
+      colorGroup "selesnya" [Green, White],
+      colorGroup "dimir" [Blue, Black],
+      colorGroup "orzhov" [White, Black],
+      colorGroup "izzet" [Red, Blue],
+      colorGroup "gruul" [Red, Green],
+      colorGroup "azorius" [Blue, White],
+      colorGroup "rakdos" [Black, Red],
+      colorGroup "simic" [Green, Blue],
+      -- Alaran Shards
+      colorGroup "bant" [White, Green, Blue],
+      colorGroup "esper" [Blue, White, Black],
+      colorGroup "grixis" [Black, Blue, Red],
+      colorGroup "jund" [Red, Black, Green],
+      colorGroup "naya" [Green, Red, White],
+      -- Tarkirian Wedges
+      colorGroup "abzan" [White, Black, Green],
+      colorGroup "jeskai" [White, Blue, Red],
+      colorGroup "sultai" [Blue, Black, Green],
+      colorGroup "mardu" [White, Black, Red],
+      colorGroup "temur" [Blue, Red, Green],
+      -- Multicolor
+      multiColor
+    ]
+  where
+    colorGroup :: String -> [Color] -> Parser Colors
+    colorGroup name xs = try (string name) >> return (Colors $ Set.fromList xs)
+    multiColor :: Parser Colors
+    multiColor = do
+      xs <- many color
+      return $ Colors $ Set.fromList xs
+
+criterion :: Parser Criteria
+criterion =
+  choice
+    [ ColorIdentityIs <$> keywords ["c", "color"] ":" colors,
+      ColorIdentityLTE <$> 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", "e", "expansion"] ":" literal,
+      CardTypeContains <$> keywords ["t", "type"] ":" literal,
+      OracleTextContains <$> keywords ["o", "oracle"] ":" literal,
+      NameContains <$> literal
+    ]
+  where
+    -- Attempt a keyword and operator pair without consuming input.
+    keyword :: String -> String -> Parser String
+    keyword operator name = try $ string (name <> operator)
+
+    -- Attempt to match a set of keywords with an operator, using parser on success.
+    keywords :: [String] -> String -> Parser a -> Parser a
+    keywords names operator parser = (choice $ map (keyword operator) names) >> parser
+
+search :: Parser Search
+search = do
+  criteria <- spaces >> sepEndBy criterion spaces
+  return $ Search criteria
+
+parseQuery :: T.Text -> Either ParseError Search
+parseQuery = Text.Parsec.parse search "search"

src/Tutor/Select.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tutor.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
+
+
+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 :__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]}

stack.yaml

@@ -0,0 +1,69 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-19.0
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+  - hspec-wai-0.11.0@sha256:79f8aab21161cd551e0bb740f5416fb622fe94f710bedc97dabd39fe901b5291,2314
+  - hspec-wai-json-0.11.0@sha256:1fdd66a61c84a9ba6f2e1673ed49b2da1f57f025cd3fb9a46d62620ff9259d63,1629
+  - parsec-extra-0.2.0.0@sha256:47f16e5d00cb62db52d126903787dcccc94d500cfbcb54316f5db00f31da4fa2,735
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack.yaml.lock

@@ -0,0 +1,33 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: hspec-wai-0.11.0@sha256:79f8aab21161cd551e0bb740f5416fb622fe94f710bedc97dabd39fe901b5291,2314
+    pantry-tree:
+      size: 809
+      sha256: 7a3bceb28c15079f039a3d5c0b639f887ae881c27359b43f46145db3845c4795
+  original:
+    hackage: hspec-wai-0.11.0@sha256:79f8aab21161cd551e0bb740f5416fb622fe94f710bedc97dabd39fe901b5291,2314
+- completed:
+    hackage: hspec-wai-json-0.11.0@sha256:1fdd66a61c84a9ba6f2e1673ed49b2da1f57f025cd3fb9a46d62620ff9259d63,1629
+    pantry-tree:
+      size: 349
+      sha256: c25b93d8e0140a9ea24605199de5065967cd5fceeacac2b7f7d0747ab2142778
+  original:
+    hackage: hspec-wai-json-0.11.0@sha256:1fdd66a61c84a9ba6f2e1673ed49b2da1f57f025cd3fb9a46d62620ff9259d63,1629
+- completed:
+    hackage: parsec-extra-0.2.0.0@sha256:47f16e5d00cb62db52d126903787dcccc94d500cfbcb54316f5db00f31da4fa2,735
+    pantry-tree:
+      size: 225
+      sha256: 8d8d15ac5aca977855d1fe89f3f23ecbbddc604e3cb887af5c27b540dba49ffc
+  original:
+    hackage: parsec-extra-0.2.0.0@sha256:47f16e5d00cb62db52d126903787dcccc94d500cfbcb54316f5db00f31da4fa2,735
+snapshots:
+- completed:
+    size: 616897
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/0.yaml
+    sha256: bbf2be02f17940bac1f87cb462d4fb0c3355de6dcfc53d84f4f9ad3ee2164f65
+  original: lts-19.0

test/AppSpec.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module AppSpec (spec) where
+
+import Database.SQLite.Simple (execute_, withConnection)
+import System.Envy (decodeWithDefaults)
+import Test.Hspec
+import Test.Hspec.Wai
+import Tutor.Api (app)
+import Tutor.Config
+import Tutor.Database (initDb)
+
+spec :: Spec
+spec = do
+  with startApp $ do
+    describe "GET /search" $ do
+      it "responds with 200" $ do
+        get "/search" `shouldRespondWith` 200
+  where
+    startApp = do
+      config <- decodeWithDefaults (defaultConfig {tutorDatabase = "test.db"}) :: IO Config
+      initDb (tutorDatabase config)
+      resetDb (tutorDatabase config)
+      return $ app config
+    resetDb dbFile = do
+      withConnection dbFile $ \conn ->
+        mapM_
+          (execute_ conn)
+          [ "DELETE FROM copies",
+            "DELETE FROM cards"
+          ]

test/SearchParserSpec.hs

@@ -0,0 +1,201 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SearchParserSpec (spec) where
+
+import Data.Text
+import Tutor.Search
+import Tutor.SearchParser (parseQuery)
+import Test.Hspec
+import qualified Text.Parsec.Error
+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 (toColors [White])])
+      it "handles color:black" $ do
+        parseSearch "color:black" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black])])
+      it "handles color:blue" $ do
+        parseSearch "color:blue" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue])])
+      it "handles color:green" $ do
+        parseSearch "color:green" `shouldBe` Right (Search [ColorIdentityIs (toColors [Green])])
+      it "handles color:red" $ do
+        parseSearch "color:red" `shouldBe` Right (Search [ColorIdentityIs (toColors [Red])])
+      it "handles c:white" $ do
+        parseSearch "c:white" `shouldBe` Right (Search [ColorIdentityIs (toColors [White])])
+      it "handles c:black" $ do
+        parseSearch "c:black" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black])])
+      it "handles c:blue" $ do
+        parseSearch "c:blue" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue])])
+      it "handles c:green" $ do
+        parseSearch "c:green" `shouldBe` Right (Search [ColorIdentityIs (toColors [Green])])
+      it "handles c:red" $ do
+        parseSearch "c:red" `shouldBe` Right (Search [ColorIdentityIs (toColors [Red])])
+    describe "Ravnican guilds" $ do
+      it "handles color:boros" $ do
+        parseSearch "color:boros" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Red])])
+      it "handles c:boros" $ do
+        parseSearch "c:boros" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Red])])
+      it "handles color:golgari" $ do
+        parseSearch "color:golgari" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Green])])
+      it "handles c:golgari" $ do
+        parseSearch "c:golgari" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Green])])
+      it "handles color:selesnya" $ do
+        parseSearch "color:selesnya" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Green])])
+      it "handles c:selesnya" $ do
+        parseSearch "c:selesnya" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Green])])
+      it "handles color:dimir" $ do
+        parseSearch "color:dimir" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Blue])])
+      it "handles c:dimir" $ do
+        parseSearch "c:dimir" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Blue])])
+      it "handles color:orzhov" $ do
+        parseSearch "color:orzhov" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black])])
+      it "handles c:orzhov" $ do
+        parseSearch "c:orzhov" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black])])
+      it "handles color:izzet" $ do
+        parseSearch "color:izzet" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue, Red])])
+      it "handles c:izzet" $ do
+        parseSearch "c:izzet" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue, Red])])
+      it "handles color:gruul" $ do
+        parseSearch "color:gruul" `shouldBe` Right (Search [ColorIdentityIs (toColors [Green, Red])])
+      it "handles c:gruul" $ do
+        parseSearch "c:gruul" `shouldBe` Right (Search [ColorIdentityIs (toColors [Green, Red])])
+      it "handles color:azorius" $ do
+        parseSearch "color:azorius" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue])])
+      it "handles c:azorius" $ do
+        parseSearch "c:azorius" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue])])
+      it "handles color:rakdos" $ do
+        parseSearch "color:rakdos" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Red])])
+      it "handles c:rakdos" $ do
+        parseSearch "c:rakdos" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Red])])
+      it "handles color:simic" $ do
+        parseSearch "color:simic" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue, Green])])
+      it "handles c:simic" $ do
+        parseSearch "c:simic" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue, Green])])
+    describe "Alaran shards" $ do
+      it "handles color:bant" $ do
+        parseSearch "color:bant" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue, Green])])
+      it "handles c:bant" $ do
+        parseSearch "c:bant" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue, Green])])
+      it "handles color:esper" $ do
+        parseSearch "color:esper" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black, Blue])])
+      it "handles c:esper" $ do
+        parseSearch "c:esper" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black, Blue])])
+      it "handles color:grixis" $ do
+        parseSearch "color:grixis" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Blue, Red])])
+      it "handles c:grixis" $ do
+        parseSearch "c:grixis" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Blue, Red])])
+      it "handles color:jund" $ do
+        parseSearch "color:jund" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Green, Red])])
+      it "handles c:jund" $ do
+        parseSearch "c:jund" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Green, Red])])
+      it "handles color:naya" $ do
+        parseSearch "color:naya" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Green, Red])])
+      it "handles c:naya" $ do
+        parseSearch "c:naya" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Green, Red])])
+    describe "Tarkirian wedges" $ do
+      it "handles color:abzan" $ do
+        parseSearch "color:abzan" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black, Green])])
+      it "handles c:abzan" $ do
+        parseSearch "c:abzan" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black, Green])])
+      it "handles color:jeskai" $ do
+        parseSearch "color:jeskai" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue, Red])])
+      it "handles c:jeskai" $ do
+        parseSearch "c:jeskai" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue, Red])])
+      it "handles color:sultai" $ do
+        parseSearch "color:sultai" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Blue, Green])])
+      it "handles c:sultai" $ do
+        parseSearch "c:sultai" `shouldBe` Right (Search [ColorIdentityIs (toColors [Black, Blue, Green])])
+      it "handles color:mardu" $ do
+        parseSearch "color:mardu" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black, Red])])
+      it "handles c:mardu" $ do
+        parseSearch "c:mardu" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Black, Red])])
+      it "handles color:temur" $ do
+        parseSearch "color:temur" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue, Green, Red])])
+      it "handles c:temur" $ do
+        parseSearch "c:temur" `shouldBe` Right (Search [ColorIdentityIs (toColors [Blue, Green, Red])])
+    describe "Multicolor" $ do
+      it "handles color:wbugr" $ do
+        parseSearch "color:wbugr" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue, Black, Green, Red])])
+      it "handles c:wbugr" $ do
+        parseSearch "c:wbugr" `shouldBe` Right (Search [ColorIdentityIs (toColors [White, Blue, Black, Green, Red])])
+      it "handles a lack of colors" $ do
+        parseSearch "c:" `shouldBe` Right (Search [ColorIdentityIs (toColors [])])
+    describe "Color ranges" $ do
+      it "handles color<=gr" $ do
+        parseSearch "color<=gr" `shouldBe` Right (Search [ColorIdentityLTE (toColors [Green, Red])])
+      it "handles c<=gr" $ do
+        parseSearch "c<=gr" `shouldBe` Right (Search [ColorIdentityLTE (toColors [Green, Red])])
+      it "handles color>=gr" $ do
+        parseSearch "color>=gr" `shouldBe` Right (Search [ColorIdentityGTE (toColors [Green, Red])])
+      it "handles c>=gr" $ do
+        parseSearch "c>=gr" `shouldBe` Right (Search [ColorIdentityGTE (toColors [Green, Red])])
+    -- 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 -> Either Text.Parsec.Error.ParseError Search
+    parseSearch = parseQuery

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

www/public/api/index.html

@@ -0,0 +1,24 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <title>Redoc</title>
+    <!-- needed for adaptive design -->
+    <meta charset="utf-8"/>
+    <meta name="viewport" content="width=device-width, initial-scale=1">
+    <link href="https://fonts.googleapis.com/css?family=Montserrat:300,400,700|Roboto:300,400,700" rel="stylesheet">
+
+    <!--
+    Redoc doesn't change outer page styles
+    -->
+    <style>
+      body {
+        margin: 0;
+        padding: 0;
+      }
+    </style>
+  </head>
+  <body>
+    <redoc spec-url='/api/openapi.json'></redoc>
+    <script src="https://cdn.jsdelivr.net/npm/redoc@latest/bundles/redoc.standalone.js"> </script>
+  </body>
+</html>

www/public/index.html

@@ -1,6 +1,6 @@
 <html>
     <head>
-        <title>Bulk Tagging Dashboard</title>
+        <title>Tutor</title>
         <meta name="viewport" content="width=device-width, initial-scale=1">
         <script type="text/javascript" src="elm.js"></script>
         <link rel="preconnect" href="https://fonts.googleapis.com">