Re-designed the entire database, need to verify all existing features. However i do belive this is a more scalable solution
This commit is contained in:
parent
a64131327c
commit
d43b5f2cc5
5 changed files with 390 additions and 87 deletions
src
|
|
@ -13,64 +13,157 @@ import Config (getDbPath)
|
|||
import Data.Text (Text, isInfixOf)
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Algorithm.Lex (Operator)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
|
||||
{-
|
||||
In this module we handle the "bottom" requests, these are made using Joins with only the minimum amount of data needed
|
||||
|
||||
Then the ID of the valid cards is used to fetch a full "Card" with all fields needed to show to the user
|
||||
-}
|
||||
|
||||
data Tree = Funct Operator Tree Tree | Holder [Card]
|
||||
|
||||
|
||||
|
||||
|
||||
data ImageUris = ImageUris
|
||||
Int
|
||||
Int
|
||||
T.Text
|
||||
T.Text
|
||||
T.Text
|
||||
T.Text
|
||||
T.Text
|
||||
T.Text
|
||||
|
||||
instance FromRow ImageUris where
|
||||
fromRow = ImageUris <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
|
||||
|
||||
|
||||
data TempCardFace = TempCardFace
|
||||
Int
|
||||
Int
|
||||
T.Text
|
||||
(Maybe Int)
|
||||
(Maybe T.Text)
|
||||
(Maybe T.Text)
|
||||
(Maybe T.Text)
|
||||
|
||||
instance FromRow TempCardFace where
|
||||
fromRow = TempCardFace <$> field <*> field <*> field <*> field <*> field <*> field <*> field
|
||||
|
||||
|
||||
data TempCard = TempCard
|
||||
Int
|
||||
T.Text
|
||||
T.Text
|
||||
T.Text
|
||||
(Maybe Int)
|
||||
(Maybe T.Text)
|
||||
T.Text
|
||||
(Maybe T.Text)
|
||||
instance FromRow TempCard where
|
||||
fromRow = TempCard <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
|
||||
|
||||
data CardFace = CardFace
|
||||
Int
|
||||
Int
|
||||
T.Text
|
||||
(Maybe Int)
|
||||
(Maybe T.Text)
|
||||
(Maybe T.Text)
|
||||
(Maybe T.Text)
|
||||
ImageUris
|
||||
|
||||
|
||||
data Card = Card
|
||||
Int
|
||||
T.Text
|
||||
T.Text
|
||||
T.Text
|
||||
(Maybe T.Text)
|
||||
(Maybe Int)
|
||||
(Maybe T.Text)
|
||||
T.Text
|
||||
Int
|
||||
deriving (Show)
|
||||
(Maybe T.Text)
|
||||
[CardFace]
|
||||
|
||||
|
||||
instance Eq Card where
|
||||
(==) (Card id_ _ _ _ _ _ _ _) (Card id2_ _ _ _ _ _ _ _) = id_ == id2_
|
||||
|
||||
instance FromRow Card where
|
||||
fromRow = Card <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
|
||||
|
||||
instance ToRow Card where
|
||||
toRow (Card id_ scryfall_id lang name oracle_text image_uri type_line cmc) = toRow (id_, scryfall_id, lang, name, oracle_text, image_uri, type_line, cmc)
|
||||
(==) (Card id_ _ _ _ _ _ _ _ _ ) (Card id2_ _ _ _ _ _ _ _ _ ) = id_ == id2_
|
||||
|
||||
|
||||
runQuerySimple :: Query -> IO [Card]
|
||||
fetchCardsWithIds :: [ID] -> IO [Card]
|
||||
fetchCardsWithIds = mapM fetchCardWithId
|
||||
|
||||
fetchCardWithId :: ID -> IO Card
|
||||
fetchCardWithId (ID id) = do
|
||||
tempCardFaces <- runQueryNamed "select id, card_id, name, cmc, oracle_text, type_line, mana_cost from card_face where card_id = :val" [":val" := id] :: IO [TempCardFace]
|
||||
--We are fetchinig based on primary key, so we know the result is a single data
|
||||
[TempCard id scryfall_id lang name cmc oracle_text type_line mana_cost] <- runQueryNamed "select id, scryfall_id, lang, name, cmc, oracle_text,type_line, mana_cost from card where id = :val" [":val" := id] :: IO [TempCard]
|
||||
cardFaces <- mapM fetchImageUris tempCardFaces
|
||||
return $ Card id scryfall_id lang name cmc oracle_text type_line mana_cost cardFaces
|
||||
|
||||
fetchImageUris :: TempCardFace -> IO (CardFace)
|
||||
fetchImageUris (TempCardFace id card_id name cmc oracle_text type_line mana_cost) = do
|
||||
--We can do this only because a ImageUri row is 1:1 with CardFace in the database
|
||||
[imageUri] <- runQueryNamed "select id, card_face_id, small, normal, large, png, art_crop, border_crop from image_uris where card_face_id = :val" [":val" := id] :: IO [ImageUris]
|
||||
return $ CardFace id card_id name cmc oracle_text type_line mana_cost imageUri
|
||||
|
||||
|
||||
|
||||
runQuerySimple :: (FromRow a) => Query -> IO [a]
|
||||
runQuerySimple str = do
|
||||
dbPath <- getDbPath
|
||||
conn <- open dbPath
|
||||
query_ conn str :: IO [Card];
|
||||
query_ conn str ::(FromRow a) => IO [a];
|
||||
|
||||
runQueryNamed :: Query -> [NamedParam] -> IO [Card]
|
||||
runQueryNamed ::(FromRow a) => Query -> [NamedParam] -> IO [a]
|
||||
runQueryNamed qur parm = do
|
||||
dbPath <- getDbPath
|
||||
conn <- open dbPath
|
||||
queryNamed conn qur parm :: IO [Card]
|
||||
queryNamed conn qur parm :: (FromRow a) => IO [a]
|
||||
|
||||
|
||||
--------------------------------------------------------------
|
||||
data CardTypeLine = CardTypeLine
|
||||
Int
|
||||
T.Text
|
||||
|
||||
instance FromRow CardTypeLine where
|
||||
fromRow = CardTypeLine <$> field <*> field
|
||||
|
||||
superType :: String -> IO Tree
|
||||
superType qry = do
|
||||
res <- runQuerySimple "select id, scryfall_id, lang, name, oracle_text, image_uri, type_line, cmc from card where type_line is not null"
|
||||
return $ Holder (typeLineFilter res (T.pack qry))
|
||||
res <- runQuerySimple "select card.id, card_face.oracle_text from card inner join card_face where card.id = card_face.card_id and card_face.oracle_text is not null" :: IO [CardTypeLine]
|
||||
cards <- fetchCardsWithIds (typeLineFilter res (T.pack qry))
|
||||
return $ Holder cards
|
||||
|
||||
typeLineFilter :: [Card] -> Text -> [Card]
|
||||
typeLineFilter (card@(Card _ _ _ _ _ _ type_line _):cards) qry = if qry `isInfixOf` type_line then card:typeLineFilter cards qry else typeLineFilter cards qry
|
||||
typeLineFilter :: [CardTypeLine] -> Text -> [ID]
|
||||
typeLineFilter (card@(CardTypeLine id type_line):cards) qry = if qry `isInfixOf` type_line then ID id:typeLineFilter cards qry else typeLineFilter cards qry
|
||||
typeLineFilter [] _ = []
|
||||
--------------------------------------------------------------
|
||||
|
||||
newtype ID = ID Int
|
||||
instance FromRow ID where
|
||||
fromRow = ID <$> field
|
||||
|
||||
cmcLT :: Int -> IO Tree
|
||||
cmcLT value = do
|
||||
res <- runQueryNamed "select id, scryfall_id, lang, name, oracle_text, image_uri, type_line, cmc from card where cmc < :val" [":val" := value]
|
||||
return $ Holder res
|
||||
res <- runQueryNamed "select card.id from card inner join card_face where card.id = card_face.card_id and (card.cmc < :val or card_face.cmc < :val)" [":val" := value] :: IO [ID]
|
||||
cards <- fetchCardsWithIds res
|
||||
return $ Holder cards
|
||||
|
||||
cmcMT :: Int -> IO Tree
|
||||
cmcMT value = do
|
||||
res <- runQueryNamed "select id, scryfall_id, lang, name, oracle_text, image_uri, type_line, cmc from card where cmc > :val" [":val" := value]
|
||||
return $ Holder res
|
||||
res <- runQueryNamed "select card.id from card inner join card_face where card.id = card_face.card_id and (card.cmc > :val or card_face.cmc > :val)" [":val" := value] :: IO [ID]
|
||||
cards <- fetchCardsWithIds res
|
||||
return $ Holder cards
|
||||
|
||||
cmcEQ :: Int -> IO Tree
|
||||
cmcEQ value = do
|
||||
res <- runQueryNamed "select id, scryfall_id, lang, name, oracle_text, image_uri, type_line, cmc from card where cmc = :val" [":val" := value]
|
||||
return $ Holder res
|
||||
res <- runQueryNamed "select card.id from card inner join card_face where card.id = card_face.card_id and (card.cmc = :val or card_face.cmc = :val)" [":val" := value] :: IO [ID]
|
||||
cards <- fetchCardsWithIds res
|
||||
return $ Holder cards
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,18 +3,19 @@ module Algorithm.Lex
|
|||
( lexx
|
||||
, Token(..)
|
||||
, QueryDef(..)
|
||||
, Operator(..)) where
|
||||
, Operator(..)
|
||||
, ParseError(..)) where
|
||||
import Prelude hiding (lex)
|
||||
import Debug.Trace
|
||||
import Data.ByteString (count, putStr)
|
||||
import Data.Either
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
|
||||
lexx :: String -> Token
|
||||
lexx :: String -> Either ParseError Token
|
||||
lexx qur = do
|
||||
let collected = clearRepeatedSpaces $ collector $ strip $ stripFront $ clearIllegalCharacters qur
|
||||
let parenthesises = matchParenthesis collected 0
|
||||
let (parenthesisFixed, parenthesis) = fixSeparators collected parenthesises
|
||||
seperator parenthesisFixed parenthesis
|
||||
|
||||
|
||||
stripFront :: [Char] -> [Char]
|
||||
stripFront = dropWhile (==' ')
|
||||
|
|
@ -29,7 +30,7 @@ strip [] = []
|
|||
|
||||
|
||||
fixSeparators :: [String] -> [(Int, Int)] -> ([String], [(Int, Int)])
|
||||
fixSeparators values parenthesis@((start,end):rest) | start == 0 && end == ( length values -1) = (values, parenthesis)
|
||||
fixSeparators values parenthesis@((start,end):_) | start == 0 && end == ( length values -1) = (values, parenthesis)
|
||||
fixSeparators values parenthesis = ( ["("] ++ values ++ [")"], (0, length values + 1):map addOne parenthesis)
|
||||
|
||||
|
||||
|
|
@ -73,7 +74,12 @@ findClosing (x:xs) stackCount count = findClosing xs stackCount (count+1)
|
|||
findClosing [] _ _ = error "Unequal number of parenthesis"
|
||||
|
||||
|
||||
data Token = Func Operator Token Token | Queri QueryDef deriving Show
|
||||
newtype ParseError = ParseError String
|
||||
|
||||
data Token =
|
||||
Func Operator Token Token |
|
||||
Queri QueryDef
|
||||
deriving Show
|
||||
data QueryDef =
|
||||
SuperType String|
|
||||
Color String |
|
||||
|
|
@ -87,24 +93,41 @@ data Operator =
|
|||
Minus
|
||||
deriving Show
|
||||
|
||||
seperator :: [String] -> [(Int, Int)] -> Token
|
||||
seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of
|
||||
" ":operator:" ":"(":rightRest -> Func (extractOperator operator) (seperator (take (end-start) rest) points) (seperator (init rightRest) points)
|
||||
[] -> seperator (take (end-start) rest) points
|
||||
_ ->error "Operator need something to the right and left of it!"
|
||||
seperator [name, " ", value, ")"] _ = Queri (extractQueryDef (name, value))
|
||||
seperator a _ = error $ "Something went wrong tokenizing the input!\n" ++ (show a)
|
||||
seperator :: [String] -> [(Int, Int)] -> Either ParseError Token
|
||||
|
||||
extractQueryDef :: (String, String) -> QueryDef
|
||||
extractQueryDef ("SuperType", value) = SuperType value
|
||||
extractQueryDef ("CmcLT", value) = CMCLT (read value :: Int)
|
||||
extractQueryDef ("CmcMT", value) = CMCMT (read value :: Int)
|
||||
extractQueryDef ("CmcEQ", value) = CMCEQ (read value :: Int)
|
||||
extractQueryDef _ = error $ "This command was not valid"
|
||||
seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of
|
||||
" ":operator:" ":"(":rightRest -> case spawnBranch (extractOperator operator) (seperator (take (end-start) rest) points) (seperator (init rightRest) points) of
|
||||
Left a -> Left a
|
||||
Right b -> Right b
|
||||
[] -> seperator (take (end-start) rest) points
|
||||
a -> Left $ ParseError $ "Could not parse input, error happened at: " ++ (show (concat a))
|
||||
seperator [name, " ", value, ")"] _ = case extractQueryDef (name, value) of
|
||||
Left a -> Left a
|
||||
Right b -> Right $ Queri $ b
|
||||
seperator a _ = Left (ParseError ("Something went wrong tokenizing the input!\n" ++ (show a)))
|
||||
|
||||
spawnBranch :: Operator -> (Either ParseError Token) -> (Either ParseError Token) -> (Either ParseError Token)
|
||||
spawnBranch _ (Left res1) _ = Left res1
|
||||
spawnBranch _ _ (Left res2) = Left res2
|
||||
spawnBranch operator (Right res1) (Right res2) = Right (Func operator res1 res2)
|
||||
|
||||
|
||||
|
||||
|
||||
extractQueryDef :: (String, String) -> Either ParseError QueryDef
|
||||
extractQueryDef ("SuperType", value) = Right $ SuperType value
|
||||
extractQueryDef ("CmcLT", value) = case readMaybe value :: Maybe Int of
|
||||
Just a -> Right $ CMCLT a
|
||||
Nothing -> Left $ ParseError "Could not parse number from call to CmcLT"
|
||||
extractQueryDef ("CmcMT", value) = case readMaybe value :: Maybe Int of
|
||||
Just a -> Right $ CMCMT a
|
||||
Nothing -> Left $ ParseError "Could not parse number from call to CmcMT"
|
||||
extractQueryDef ("CmcEQ", value) = case readMaybe value :: Maybe Int of
|
||||
Just a -> Right $ CMCEQ a
|
||||
Nothing -> Left $ ParseError "Could not parse number from call to CmcEQ"
|
||||
extractQueryDef (a,b) = Left $ ParseError $ "The following command is invalid " ++ show a
|
||||
|
||||
extractOperator "union" = Union
|
||||
extractOperator "intersect" = Intersect
|
||||
extractOperator "minus" = Minus
|
||||
extractOperator _ = error $ "This operator is not defined"
|
||||
-- ((Is instant) union (Color R)) union ((Is instant) union (Color R))
|
||||
-- (((Color Red) union (Color Blue)) union ((Is instant) union (Is Enchantment)))
|
||||
|
|
@ -17,14 +17,16 @@ import Data.Aeson.Encoding (value)
|
|||
|
||||
search :: String -> IO String
|
||||
search q = do
|
||||
let tokens = lexx q
|
||||
case lexx q of
|
||||
Left (ParseError message) -> return message
|
||||
Right tokens ->do
|
||||
tree <- executeBottomQuery tokens
|
||||
let queryRes = executeQuery tree
|
||||
let hyperText = buildHtml queryRes
|
||||
return hyperText
|
||||
--In order to avoid IO when performing the operators, we fetch all the "bottom" queries first, then perform
|
||||
--the operators on them based on the Tree
|
||||
tree <- executeBottomQuery tokens
|
||||
|
||||
let queryRes = executeQuery tree
|
||||
let hyperText = buildHtml queryRes
|
||||
return hyperText
|
||||
|
||||
|
||||
|
||||
|
|
@ -57,10 +59,7 @@ executeBottomQuery (Func operator left right) = do
|
|||
|
||||
|
||||
cardToHtml :: Card -> String
|
||||
cardToHtml (Card id_ scryfall_id lang name (Just oracle_text) (Just image_uri) type_line cmc) =
|
||||
cardToHtml (Card _ _ _ name (Just cmc) (Just oracle_text) type_line (Just mana_cost) _) =
|
||||
"<div class=\"card\" style=\"text-align:center\"><h2>" ++ unpack name ++ "</h2>" ++
|
||||
"<img src=" ++ unpack image_uri ++ " width=\"200px\"/>"++
|
||||
"<p style=\"width:205px;margin: 0 auto;font-size:12;\">" ++ unpack oracle_text ++ "<p>"++" </div>"
|
||||
|
||||
|
||||
cardToHtml _ = "<h1>Could not load that card</h1>"
|
||||
235
src/Seed.hs
235
src/Seed.hs
|
|
@ -1,10 +1,10 @@
|
|||
{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
|
||||
module Seed
|
||||
( seedDataFile, seedDataWeb
|
||||
( seedDataFile, seedDataWeb, DbCard(..)
|
||||
) where
|
||||
|
||||
import Data.Aeson ( eitherDecode, FromJSON, ToJSON )
|
||||
import Data.Text
|
||||
import Data.Aeson ( eitherDecode, FromJSON (parseJSON), ToJSON (toJSON), Value (Object), (.:), fromJSON, Key, (.:?) )
|
||||
import Data.Text as T
|
||||
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
|
||||
|
|
@ -14,7 +14,28 @@ import Config
|
|||
|
||||
import GHC.Generics
|
||||
import DataFetcher (fetchData)
|
||||
import Prelude hiding (id)
|
||||
import Control.Exception (IOException, try, SomeException)
|
||||
import Data.Aeson.KeyMap (keys, insert)
|
||||
import Data.Aeson.Types (toJSONKeyKey, Parser)
|
||||
|
||||
|
||||
|
||||
data CardFace = CardFace {
|
||||
id :: Maybe Int,
|
||||
card_id :: Maybe Int,
|
||||
name:: Text,
|
||||
cmc::Maybe Float,
|
||||
oracle_text::Maybe Text,
|
||||
image_uris:: Maybe ImageUris,
|
||||
type_line :: Maybe Text,
|
||||
mana_cost:: Maybe Text
|
||||
}deriving (Show,Generic)
|
||||
instance FromJSON CardFace
|
||||
instance ToJSON CardFace
|
||||
|
||||
data ImageUris = ImageUris {
|
||||
card_face_id :: Maybe Int,
|
||||
small :: Text,
|
||||
normal :: Text,
|
||||
large :: Text,
|
||||
|
|
@ -25,24 +46,89 @@ data ImageUris = ImageUris {
|
|||
instance FromJSON ImageUris
|
||||
instance ToJSON ImageUris
|
||||
|
||||
data Legalities = Legalities{
|
||||
cardId :: Maybe Int,
|
||||
standard :: Text,
|
||||
future :: Text,
|
||||
historic::Text,
|
||||
gladiator::Text,
|
||||
pioneer::Text,
|
||||
explorer::Text,
|
||||
modern::Text,
|
||||
legacy::Text,
|
||||
pauper::Text,
|
||||
vintage::Text,
|
||||
penny::Text,
|
||||
commander::Text,
|
||||
brawl::Text,
|
||||
historicbrawl::Text,
|
||||
alchemy::Text,
|
||||
paupercommander::Text,
|
||||
duel::Text,
|
||||
oldschool::Text,
|
||||
premodern::Text,
|
||||
predh::Text
|
||||
}deriving (Show,Generic)
|
||||
instance FromJSON Legalities
|
||||
|
||||
data Card = Card{
|
||||
object :: Text,
|
||||
id :: Text,
|
||||
c_id :: Text,
|
||||
lang :: Text,
|
||||
name :: Text,
|
||||
oracle_text :: Maybe Text,
|
||||
image_uris :: Maybe ImageUris,
|
||||
type_line :: Maybe Text,
|
||||
cmc :: Int
|
||||
c_name:: Text,
|
||||
layout:: Text,
|
||||
c_cmc:: Maybe Float,
|
||||
c_oracle_text:: Maybe Text,
|
||||
c_type_line :: Maybe Text,
|
||||
c_mana_cost:: Maybe Text,
|
||||
card_faces:: Maybe [CardFace],
|
||||
c_image_uris :: Maybe ImageUris,
|
||||
legalities :: Legalities
|
||||
} deriving (Show,Generic)
|
||||
|
||||
instance FromJSON Card
|
||||
instance ToJSON Card
|
||||
instance FromJSON Card where
|
||||
parseJSON (Object v) = do
|
||||
c_name <- v.: "name"
|
||||
c_id <- v .: "id"
|
||||
lang <- v .: "lang"
|
||||
c_cmc <- v .:? "cmc"
|
||||
c_oracle_text <- v .:? "oracle_text"
|
||||
c_type_line <- v .:? "type_line"
|
||||
c_mana_cost <- v .:? "mana_cost"
|
||||
card_faces <- v .:? "card_faces"
|
||||
layout <- v .: "layout"
|
||||
c_image_uris <- v .:? "image_uris"
|
||||
legalities <- v .: "legalities"
|
||||
return (Card {
|
||||
c_id = c_id,
|
||||
lang = lang,
|
||||
c_name = c_name,
|
||||
c_cmc = c_cmc,
|
||||
c_oracle_text = c_oracle_text,
|
||||
c_type_line = c_type_line,
|
||||
c_mana_cost = c_mana_cost,
|
||||
card_faces = card_faces,
|
||||
layout = layout,
|
||||
c_image_uris = c_image_uris,
|
||||
legalities = legalities
|
||||
})
|
||||
parseJSON a = error $ "could not parse card " ++ (show a)
|
||||
|
||||
instance ToRow Card where
|
||||
toRow (Card object id lang name oracle_text (Just (ImageUris _ image_link _ _ _ _ )) type_line cmc) =
|
||||
toRow (id, lang, name, oracle_text, image_link, type_line, cmc)
|
||||
toRow (Card object id lang name oracle_text Nothing type_line cmc) = toRow (id, lang, name, oracle_text, Nothing:: (Maybe Text), type_line, cmc)
|
||||
data DbCard = DbCard Int Text Text Text Text (Maybe Float) (Maybe Text) (Maybe Text) (Maybe Text)
|
||||
|
||||
instance ToRow Legalities
|
||||
|
||||
instance ToRow DbCard where
|
||||
toRow (DbCard id scryfall_id lang name layout cmc oracle_text type_line mana_cost) =
|
||||
toRow (id, scryfall_id, lang, name, cmc, oracle_text, type_line, mana_cost)
|
||||
|
||||
|
||||
instance ToRow CardFace where
|
||||
toRow(CardFace c_id card_id name cmc oracle_text image_uris type_line mana_cost) =
|
||||
toRow (c_id, card_id, name, cmc, oracle_text, type_line, mana_cost)
|
||||
|
||||
instance ToRow ImageUris where
|
||||
toRow (ImageUris card_face_id small normal large png art_crop border_crop) =
|
||||
toRow (card_face_id, small, normal, large, png, art_crop, border_crop)
|
||||
|
||||
seedDataFile :: IO ()
|
||||
seedDataFile = do
|
||||
|
|
@ -57,17 +143,33 @@ seedDataWeb :: IO ()
|
|||
seedDataWeb = do
|
||||
dat <- (eitherDecode <$> getJSONWeb) :: IO (Either String [Card])
|
||||
seedData dat
|
||||
|
||||
|
||||
|
||||
|
||||
cardToDbCard :: Int -> Card -> DbCard
|
||||
cardToDbCard id (Card scryfall_id lang c_name layout c_cmc c_oracle_text c_type_line c_mana_cost _ _ _) =
|
||||
DbCard id scryfall_id lang c_name layout c_cmc c_oracle_text c_type_line c_mana_cost
|
||||
|
||||
|
||||
seedData d = do
|
||||
dbPath <- getDbPath
|
||||
conn <- open dbPath
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS card (id INTEGER PRIMARY KEY, scryfall_id TEXT, lang TEXT, name TEXT, oracle_text TEXT, image_uri TEXT, type_line TEXT, cmc INT)"
|
||||
execute_ conn "DROP TABLE IF EXISTS card"
|
||||
execute_ conn "DROP TABLE IF EXISTS image_uris"
|
||||
execute_ conn "DROP TABLE IF EXISTS card_face"
|
||||
execute_ conn "DROP TABLE IF EXISTS legalities"
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS card (id INTEGER PRIMARY KEY, scryfall_id TEXT, lang TEXT, name TEXT, cmc INT, oracle_text TEXT, type_line TEXT, mana_cost TEXT)"
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS card_face (id INTEGER PRIMARY KEY,card_id INT, name TEXT, cmc INT, oracle_text TEXT, type_line TEXT, mana_cost TEXT)"
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS image_uris (id INTEGER PRIMARY KEY, card_face_id INT, small TEXT, normal TEXT, large TEXT, png TEXT, art_crop TEXT, border_crop TEXT)"
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS legalities (id INTEGER PRIMARY KEY, card_id INT, standard BOOL, future BOOL, historic BOOL, gladiator BOOL, pioneer BOOL, explorer BOOL, modern BOOL, legacy BOOL, pauper BOOL, vintage BOOL, penny BOOL, commander BOOL, brawl BOOL, historicbrawl BOOL, alchemy BOOL, paupercommander BOOL, duel BOOL, oldschool BOOL, premodern BOOL, predh BOOL)"
|
||||
|
||||
|
||||
case d of
|
||||
Left err -> putStrLn err
|
||||
Right ps -> insertCards conn ps
|
||||
Right ps -> insertCards conn 0 0 ps
|
||||
|
||||
|
||||
|
||||
|
||||
getJSON :: String -> IO B.ByteString
|
||||
getJSON = B.readFile
|
||||
|
|
@ -75,10 +177,93 @@ getJSON = B.readFile
|
|||
getJSONWeb :: IO B.ByteString
|
||||
getJSONWeb = fetchData
|
||||
|
||||
insertCards :: Connection -> [Card] -> IO()
|
||||
insertCards conn ((card):cards) = do
|
||||
execute conn "INSERT INTO card (scryfall_id, lang, name, oracle_text, image_uri, type_line, cmc) VALUES (?,?,?,?,?,?,?)" card
|
||||
insertCards conn cards
|
||||
return ()
|
||||
insertCards conn [] = return ()
|
||||
---------------------------------------------------------------------------------------------------------
|
||||
|
||||
insertCards :: Connection -> Int -> Int -> [Card] -> IO()
|
||||
|
||||
--Skip illegal card types that are not relevant (These are difficult to parse as they contain non standard card formats)
|
||||
insertCards conn card_id card_face_id ((Card _ _ _ layout _ _ _ _ _ _ _):cards) | unpack layout `Prelude.elem` ["scheme", "token", "double_faced_token", "emblem", "art_series", "vanguard", "host"] =
|
||||
insertCards conn card_id card_face_id cards
|
||||
|
||||
--This should in theory never happen, however it is here for full coverage
|
||||
insertCards _ _ _ (card@(Card _ _ _ _ _ _ _ _ Nothing Nothing _):_) = do
|
||||
error $ "This cannot happen! No card can not have cardfaces as well as no image_uris on top level. Please fix ur data!"
|
||||
|
||||
--This will be ran when the card is single face (most cards)
|
||||
insertCards conn card_id card_face_id (card@(Card _ _ c_name _ c_cmc c_oracle_text c_type_line c_mana_cost Nothing image_uris@(Just (ImageUris _ small normal large png art_crop border_crop)) legal):cards) = do
|
||||
let legalities = insertIdLegalities legal card_id
|
||||
let cardFace = CardFace (Just card_face_id) (Just card_id) c_name c_cmc c_oracle_text Nothing c_type_line c_mana_cost
|
||||
let imageUris = ImageUris (Just card_face_id) small normal large png art_crop border_crop
|
||||
let dbCard = cardToDbCard card_id card
|
||||
insertRows conn dbCard legalities [(cardFace, imageUris)]
|
||||
insertCards conn (card_id + 1) (card_face_id + 1) cards
|
||||
|
||||
--This will be ran when a card is multi face
|
||||
insertCards conn card_id card_face_id (card@(Card _ _ _ _ _ _ _ _ (Just card_faces) Nothing legal):cards) = do
|
||||
let legalities = insertIdLegalities legal card_id
|
||||
let dbCard = cardToDbCard card_id card
|
||||
let cardFacesAndImageUris = addCardIdToCardFaces card_id card_face_id card_faces
|
||||
insertRows conn dbCard legalities cardFacesAndImageUris
|
||||
insertCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards
|
||||
|
||||
--This will be ran when a card contains multiple cards on the front
|
||||
insertCards conn card_id card_face_id (card@(Card _ _ _ _ _ _ _ _ (Just card_faces) (Just image_uris) legal):cards) = do
|
||||
let legalities = insertIdLegalities legal card_id
|
||||
let dbCard = cardToDbCard card_id card
|
||||
let cardFacesAndImageUris = addCardIdAndImageUrisToCardFaces card_id card_face_id image_uris card_faces
|
||||
insertRows conn dbCard legalities cardFacesAndImageUris
|
||||
insertCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards
|
||||
|
||||
insertCards _ _ _ [] = return ()
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
insertIdLegalities :: Legalities -> Int -> Legalities
|
||||
insertIdLegalities (Legalities Nothing a b c d e f g h i j k l m n o p q r s t) id = Legalities (Just id) a b c d e f g h i j k l m n o p q r s t
|
||||
insertIdLegalities _ _ = error $ "Illegal id insert into data legality"
|
||||
|
||||
---------------------------------------------------------------------------------------------------------
|
||||
addCardIdAndImageUrisToCardFaces :: Int -> Int -> ImageUris -> [CardFace] -> [(CardFace, ImageUris)]
|
||||
addCardIdAndImageUrisToCardFaces card_id card_face_id image_uri (card_face:faces) = addCardIdAndImageUrisToCardFace card_id card_face_id image_uri card_face : addCardIdAndImageUrisToCardFaces card_id (card_face_id+1) image_uri faces
|
||||
addCardIdAndImageUrisToCardFaces _ _ _ [] = []
|
||||
|
||||
|
||||
addCardIdAndImageUrisToCardFace :: Int -> Int -> ImageUris -> CardFace -> (CardFace, ImageUris)
|
||||
addCardIdAndImageUrisToCardFace card_id card_face_id (ImageUris _ small normal large png art_crop border_crop) (CardFace Nothing Nothing c_name c_cmc c_oracle_text Nothing c_type_line c_mana_cost) =
|
||||
(CardFace (Just card_face_id) (Just card_id) c_name c_cmc c_oracle_text Nothing c_type_line c_mana_cost, ImageUris (Just card_face_id) small normal large png art_crop border_crop)
|
||||
addCardIdAndImageUrisToCardFace _ _ _ _ = error $ "This cardface and imageUris are not compatible"
|
||||
|
||||
|
||||
addCardIdToCardFace :: Int -> Int -> CardFace -> (CardFace,ImageUris)
|
||||
addCardIdToCardFace card_id card_face_id (CardFace Nothing Nothing c_name c_cmc c_oracle_text (Just (ImageUris i_card_face_id small normal large png art_crop border_crop)) c_type_line c_mana_cost) =
|
||||
(CardFace (Just card_face_id) (Just card_id) c_name c_cmc c_oracle_text Nothing c_type_line c_mana_cost, ImageUris (Just card_face_id) small normal large png art_crop border_crop)
|
||||
addCardIdToCardFace _ _ _ = error $ "This cardface already has an id associated with it!"
|
||||
|
||||
|
||||
addCardIdToCardFaces :: Int -> Int -> [CardFace] -> [(CardFace, ImageUris)]
|
||||
addCardIdToCardFaces card_id card_face_id (card:cards) = addCardIdToCardFace card_id card_face_id card : addCardIdToCardFaces card_id (card_face_id +1) cards
|
||||
addCardIdToCardFaces _ _ [] = []
|
||||
|
||||
|
||||
|
||||
insertRows :: Connection -> DbCard -> Legalities -> [(CardFace, ImageUris)] -> IO()
|
||||
insertRows conn dbCard legalities face_uri = do
|
||||
mapM_ (insertCardFaceImageUris conn) face_uri
|
||||
insertCard conn dbCard
|
||||
insertLegalities conn legalities
|
||||
|
||||
insertCardFaceImageUris :: Connection -> (CardFace, ImageUris) -> IO ()
|
||||
insertCardFaceImageUris conn (cardFace, imageUris) = do
|
||||
execute conn "INSERT INTO card_face (id, card_id, name, cmc, oracle_text, type_line, mana_cost) VALUES (?,?,?,?,?,?,?)" cardFace
|
||||
execute conn "INSERT INTO image_uris (card_face_id, small , normal , large , png , art_crop, border_crop) VALUES (?,?,?,?,?,?,?)" imageUris
|
||||
|
||||
|
||||
insertCard :: Connection -> DbCard -> IO ()
|
||||
insertCard conn card = do
|
||||
execute conn "INSERT INTO card (id, scryfall_id, lang, name, cmc, oracle_text, type_line, mana_cost ) VALUES (?,?,?,?,?,?,?,?)" card
|
||||
|
||||
insertLegalities :: Connection -> Legalities -> IO ()
|
||||
insertLegalities conn legalities = do
|
||||
execute conn "INSERT INTO legalities (card_id, standard , future , historic , gladiator , pioneer , explorer , modern , legacy , pauper , vintage , penny , commander , brawl , historicbrawl , alchemy , paupercommander , duel , oldschool , premodern, predh ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" legalities
|
||||
|
|
@ -2,16 +2,19 @@
|
|||
<html>
|
||||
<body>
|
||||
|
||||
<h1>This is a heading</h1>
|
||||
<div>
|
||||
<h1>This is a heading</h1>
|
||||
|
||||
<p>This site will be to search for magic the gathering cards using a custom sort of DSL!</p>
|
||||
<p>This site will be to search for magic the gathering cards using a custom sort of DSL!</p>
|
||||
|
||||
|
||||
<form method="POST" action="/api/req">
|
||||
<textarea rows="5" cols="33" name="query"></textarea>
|
||||
<button type="submit">SHIP IT!</button>
|
||||
</form>
|
||||
</div>
|
||||
|
||||
|
||||
<form method="POST" action="/api/req">
|
||||
<textarea rows="5" cols="33" name="query"></textarea>
|
||||
<button type="submit">SHIP IT!</button>
|
||||
</form>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue