Compare commits
28 commits
Author | SHA1 | Date | |
---|---|---|---|
3eff953def | |||
cc1ae8e395 | |||
ce49c394dd | |||
3e04e4f2cf | |||
9fcaf3f20d | |||
492b4fa71b | |||
384affe29e | |||
6e1ea5c910 | |||
b9d2cc8775 | |||
fd35a47dc9 | |||
70f3fcf8f7 | |||
f6936baae7 | |||
4df535f3c5 | |||
070487f924 | |||
d032f9b294 | |||
0957f6f150 | |||
a0d3f45a9e | |||
192f4a935c | |||
a2434a2306 | |||
3aabb35da5 | |||
47c85f026c | |||
6030be74c4 | |||
7f8a853d3c | |||
89e3322670 | |||
b460218251 | |||
9bd190b609 | |||
c69ef215b5 | |||
746ca6a507 |
22 changed files with 1500 additions and 27 deletions
|
@ -1,3 +1,4 @@
|
||||||
|
.git
|
||||||
.DS_Store
|
.DS_Store
|
||||||
.idea
|
.idea
|
||||||
*.log
|
*.log
|
||||||
|
@ -13,3 +14,7 @@ www/elm-stuff
|
||||||
www/node_modules
|
www/node_modules
|
||||||
www/package-lock.json
|
www/package-lock.json
|
||||||
www/public/elm.js
|
www/public/elm.js
|
||||||
|
|
||||||
|
.stack-work/
|
||||||
|
test.db
|
||||||
|
tutor.db
|
||||||
|
|
5
.gitignore
vendored
5
.gitignore
vendored
|
@ -8,3 +8,8 @@ tmp/
|
||||||
*.egg
|
*.egg
|
||||||
build
|
build
|
||||||
htmlcov
|
htmlcov
|
||||||
|
|
||||||
|
.stack-work/
|
||||||
|
tutor.cabal
|
||||||
|
test.db
|
||||||
|
tutor.db
|
||||||
|
|
44
Dockerfile
44
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 \
|
FROM base as build
|
||||||
PIP_DISABLE_PIP_VERSION_CHECK=1 \
|
|
||||||
PIP_NO_CACHE_DIR=1 \
|
|
||||||
POETRY_VERSION=1.1.4
|
|
||||||
|
|
||||||
RUN apk add --no-cache gcc libffi-dev musl-dev openssl-dev rust cargo
|
COPY --from=dependencies /root/.stack /root/.stack
|
||||||
RUN pip install "poetry==$POETRY_VERSION"
|
COPY . /build/
|
||||||
RUN python -m venv /venv
|
WORKDIR /build
|
||||||
|
RUN stack build --system-ghc
|
||||||
COPY pyproject.toml poetry.lock ./
|
RUN mv "$(stack path --local-install-root --system-ghc)/bin" /build/bin
|
||||||
RUN poetry export -f requirements.txt | /venv/bin/pip install -r /dev/stdin
|
|
||||||
|
|
||||||
COPY . .
|
|
||||||
RUN poetry build && /venv/bin/pip install dist/*.whl
|
|
||||||
|
|
||||||
FROM base as frontend
|
FROM base as frontend
|
||||||
|
|
||||||
RUN apk add --no-cache curl
|
|
||||||
COPY www /www
|
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 \
|
RUN curl -sL --output /bin/elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz \
|
||||||
&& gunzip elm.gz \
|
&& gunzip /bin/elm.gz \
|
||||||
&& chmod +x elm \
|
&& chmod +x /bin/elm \
|
||||||
&& cd /www \
|
&& 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
|
FROM base as final
|
||||||
|
|
||||||
|
@ -37,9 +32,6 @@ ENV TUTOR_PORT=8888 \
|
||||||
TUTOR_DATABASE=/tutor.db \
|
TUTOR_DATABASE=/tutor.db \
|
||||||
TUTOR_STATIC=/www
|
TUTOR_STATIC=/www
|
||||||
|
|
||||||
RUN apk add sqlite
|
COPY --from=build /build/bin /app
|
||||||
COPY --from=builder /venv /venv
|
|
||||||
COPY --from=frontend /www/public /www
|
COPY --from=frontend /www/public /www
|
||||||
COPY docker-entrypoint.sh tables.sql ./
|
ENTRYPOINT ["/app/tutor-exe"]
|
||||||
ENTRYPOINT ["./docker-entrypoint.sh"]
|
|
||||||
CMD ["server"]
|
|
||||||
|
|
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
10
app/Main.hs
Normal file
10
app/Main.hs
Normal file
|
@ -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
|
71
package.yaml
Normal file
71
package.yaml
Normal file
|
@ -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
|
17
src/Tutor.hs
Normal file
17
src/Tutor.hs
Normal file
|
@ -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)
|
262
src/Tutor/Api.hs
Normal file
262
src/Tutor/Api.hs
Normal file
|
@ -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
|
30
src/Tutor/Card.hs
Normal file
30
src/Tutor/Card.hs
Normal file
|
@ -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)
|
||||||
|
|
31
src/Tutor/Config.hs
Normal file
31
src/Tutor/Config.hs
Normal file
|
@ -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
|
333
src/Tutor/Database.hs
Normal file
333
src/Tutor/Database.hs
Normal file
|
@ -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
|
12
src/Tutor/Pagination.hs
Normal file
12
src/Tutor/Pagination.hs
Normal file
|
@ -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]
|
||||||
|
}
|
73
src/Tutor/Search.hs
Normal file
73
src/Tutor/Search.hs
Normal file
|
@ -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)
|
122
src/Tutor/SearchParser.hs
Normal file
122
src/Tutor/SearchParser.hs
Normal file
|
@ -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"
|
149
src/Tutor/Select.hs
Normal file
149
src/Tutor/Select.hs
Normal file
|
@ -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]}
|
69
stack.yaml
Normal file
69
stack.yaml
Normal file
|
@ -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
|
33
stack.yaml.lock
Normal file
33
stack.yaml.lock
Normal file
|
@ -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
|
31
test/AppSpec.hs
Normal file
31
test/AppSpec.hs
Normal file
|
@ -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"
|
||||||
|
]
|
201
test/SearchParserSpec.hs
Normal file
201
test/SearchParserSpec.hs
Normal file
|
@ -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
|
1
test/Spec.hs
Normal file
1
test/Spec.hs
Normal file
|
@ -0,0 +1 @@
|
||||||
|
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
24
www/public/api/index.html
Normal file
24
www/public/api/index.html
Normal file
|
@ -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>
|
|
@ -1,6 +1,6 @@
|
||||||
<html>
|
<html>
|
||||||
<head>
|
<head>
|
||||||
<title>Bulk Tagging Dashboard</title>
|
<title>Tutor</title>
|
||||||
<meta name="viewport" content="width=device-width, initial-scale=1">
|
<meta name="viewport" content="width=device-width, initial-scale=1">
|
||||||
<script type="text/javascript" src="elm.js"></script>
|
<script type="text/javascript" src="elm.js"></script>
|
||||||
<link rel="preconnect" href="https://fonts.googleapis.com">
|
<link rel="preconnect" href="https://fonts.googleapis.com">
|
||||||
|
|
Loading…
Reference in a new issue