From d2411937dc55f065e119b5f7170cc9ccfb276c9c Mon Sep 17 00:00:00 2001 From: polsevev Date: Sun, 30 Apr 2023 18:48:50 +0200 Subject: [PATCH] Added a fetcher for data, added a lot more operators. Need to add a ReadMe on how this is used2 --- Config/config.json | 3 +- app/Main.hs | 7 +++-- mtgsearch.cabal | 7 +++++ package.yaml | 3 +- src/Algorithm/BaseQuery.hs | 55 +++++++++++++++++++++++++++++------- src/Algorithm/Lex.hs | 43 +++++++++++++++++++++++----- src/Algorithm/Operator.hs | 15 +++++++--- src/Algorithm/Search.hs | 23 +++++++++------ src/Config.hs | 9 ++++-- src/DataFetcher.hs | 19 +++++++++++++ src/Seed.hs | 58 +++++++++++++++++++++++--------------- src/Site/Static/index.html | 2 +- 12 files changed, 184 insertions(+), 60 deletions(-) create mode 100644 src/DataFetcher.hs diff --git a/Config/config.json b/Config/config.json index f34d4ef..a041ee1 100644 --- a/Config/config.json +++ b/Config/config.json @@ -1,4 +1,5 @@ { "dataseedpath" : "./data/small.json", - "dbPath" : "data/db.db" + "dbPath" : "data/db.db", + "bulkDataLink" : "https://data.scryfall.io/default-cards/default-cards-20230430090702.json" } diff --git a/app/Main.hs b/app/Main.hs index 0b8dd60..0d49c7d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,13 +1,14 @@ module Main (main) where import System.Environment import Site.Host -import Seed ( seedData ) +import Seed ( seedDataFile, seedDataWeb ) import Lib - +import DataFetcher main :: IO () main = do args <- getArgs case args of - ["--seed"] -> seedData + ["--seedFromFile"] -> seedDataFile + ["--seedFromWeb"] -> seedDataWeb _ -> host diff --git a/mtgsearch.cabal b/mtgsearch.cabal index da3c219..4f02975 100644 --- a/mtgsearch.cabal +++ b/mtgsearch.cabal @@ -30,6 +30,7 @@ library Algorithm.Operator Algorithm.Search Config + DataFetcher Lib Seed Site.Host @@ -43,6 +44,8 @@ library , base >=4.7 && <5 , bytestring , directory + , http-client + , http-client-tls , scotty , sqlite-simple , text @@ -60,6 +63,8 @@ executable mtgsearch-exe , base >=4.7 && <5 , bytestring , directory + , http-client + , http-client-tls , mtgsearch , scotty , sqlite-simple @@ -79,6 +84,8 @@ test-suite mtgsearch-test , base >=4.7 && <5 , bytestring , directory + , http-client + , http-client-tls , mtgsearch , scotty , sqlite-simple diff --git a/package.yaml b/package.yaml index 885e990..9dff094 100644 --- a/package.yaml +++ b/package.yaml @@ -27,7 +27,8 @@ dependencies: - sqlite-simple - scotty - directory - +- http-client +- http-client-tls ghc-options: - -Wall - -Wcompat diff --git a/src/Algorithm/BaseQuery.hs b/src/Algorithm/BaseQuery.hs index 5ee75d9..7aa5ce0 100644 --- a/src/Algorithm/BaseQuery.hs +++ b/src/Algorithm/BaseQuery.hs @@ -1,13 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} module Algorithm.BaseQuery ( superType, - Card(..) + Card(..), + cmcLT, + cmcMT, + cmcEQ, + Tree(..) ) where import qualified Data.Text as T import Database.SQLite.Simple import Config (getDbPath) import Data.Text (Text, isInfixOf) import Control.Monad.IO.Class (MonadIO(liftIO)) +import Algorithm.Lex (Operator) + + +data Tree = Funct Operator Tree Tree | Holder [Card] + data Card = Card Int T.Text @@ -16,26 +25,52 @@ data Card = Card (Maybe T.Text) (Maybe T.Text) T.Text + Int deriving (Show) instance Eq Card where - (==) (Card id_ _ _ _ _ _ _) (Card id2_ _ _ _ _ _ _) = id_ == id2_ + (==) (Card id_ _ _ _ _ _ _ _) (Card id2_ _ _ _ _ _ _ _) = id_ == id2_ instance FromRow Card where - fromRow = Card <$> field <*> field <*> field <*> field <*> field <*> field <*> field + 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) = toRow (id_, scryfall_id, lang, name, oracle_text, image_uri, type_line) + 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) -superType :: String -> IO [Card] -superType qry = do +runQuerySimple :: Query -> IO [Card] +runQuerySimple str = do dbPath <- getDbPath conn <- open dbPath - res <- query_ conn "select id, scryfall_id, lang, name, oracle_text, image_uri, type_line from card where type_line is not null" :: IO [Card]; - return $ typeLineFilter res (T.pack qry) + query_ conn str :: IO [Card]; + +runQueryNamed :: Query -> [NamedParam] -> IO [Card] +runQueryNamed qur parm = do + dbPath <- getDbPath + conn <- open dbPath + queryNamed conn qur parm :: IO [Card] + + +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)) 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 (card@(Card _ _ _ _ _ _ type_line _):cards) qry = if qry `isInfixOf` type_line then card:typeLineFilter cards qry else typeLineFilter cards qry +typeLineFilter [] _ = [] -typeLineFilter [] _ = [] \ No newline at end of file +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 + +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 + +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 \ No newline at end of file diff --git a/src/Algorithm/Lex.hs b/src/Algorithm/Lex.hs index 444c17b..ed487b6 100644 --- a/src/Algorithm/Lex.hs +++ b/src/Algorithm/Lex.hs @@ -8,27 +8,42 @@ import Prelude hiding (lex) import Debug.Trace import Data.ByteString (count, putStr) + lexx :: String -> Token lexx qur = do - - let collected = clearRepeatedSpaces $ collector qur - let parenthesises = trace (show $ matchParenthesis collected 0) (matchParenthesis collected 0) - let (parenthesisFixed, parenthesis) = trace (show $ fixSeparators collected parenthesises) fixSeparators collected parenthesises + 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 (==' ') + +strip :: String -> String +strip (' ':as) = case strip as of + [] -> [] + _ -> ' ' : strip as +strip (a:as) = a : strip as +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 = ( ["("] ++ values ++ [")"], (0, length values + 1):map addOne parenthesis) - addOne (x,y) = (x+1, y+1) isLegal :: Char -> Bool isLegal x = x `notElem` ['(',')',' '] +clearIllegalCharacters :: String -> String +clearIllegalCharacters (c:cs) | c `elem` ['\n', '\r'] = ' ':clearIllegalCharacters cs +clearIllegalCharacters (c:cs) = c:clearIllegalCharacters cs +clearIllegalCharacters [] = [] + clearRepeatedSpaces :: [String] -> [String] clearRepeatedSpaces (a:as) = case a of " " -> " ": clearRepeatedSpaces (dropWhile (==" ") as) @@ -59,8 +74,18 @@ findClosing [] _ _ = error "Unequal number of parenthesis" data Token = Func Operator Token Token | Queri QueryDef deriving Show -data QueryDef = SuperType String| Color String deriving Show -data Operator = Union | Intersect deriving Show +data QueryDef = + SuperType String| + Color String | + CMCLT Int | + CMCMT Int | + CMCEQ Int + deriving Show +data Operator = + Union | + Intersect | + Minus + deriving Show seperator :: [String] -> [(Int, Int)] -> Token seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of @@ -72,10 +97,14 @@ seperator a _ = error $ "Something went wrong tokenizing the input!\n" ++ (show 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" 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))) \ No newline at end of file diff --git a/src/Algorithm/Operator.hs b/src/Algorithm/Operator.hs index 21853aa..ab81bc2 100644 --- a/src/Algorithm/Operator.hs +++ b/src/Algorithm/Operator.hs @@ -1,14 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Algorithm.Operator ( union, - intersect + intersect, + minus ) where -union :: [a] -> [a] -> [a] -union res1 res2 = res1 ++ res2 +union :: Eq a => [a] -> [a] -> [a] +union (a:as) bs | a `elem` bs = union as bs +union (a:as) bs = a : union as bs +union [] _ = [] intersect :: Eq a => [a] -> [a] -> [a] intersect (a:as) b = if a `elem` b then a: intersect as b else intersect as b +intersect [] _ = [] -intersect [] _ = [] \ No newline at end of file +minus :: Eq a => [a] -> [a] -> [a] +minus (a:as) bs | a `notElem` bs = a:minus as bs +minus (_:as) bs = minus as bs +minus [] _ = [] \ No newline at end of file diff --git a/src/Algorithm/Search.hs b/src/Algorithm/Search.hs index d2f7898..47ddeae 100644 --- a/src/Algorithm/Search.hs +++ b/src/Algorithm/Search.hs @@ -9,15 +9,18 @@ import qualified Data.Text as T import Algorithm.Lex import Control.Monad import Data.Text (unpack) -import Algorithm.Operator (union, intersect) +import Algorithm.Operator (union, intersect, minus) import Control.Monad.IO.Class +import Data.Aeson.Encoding (value) + -data Tree = Funct Operator Tree Tree | Holder [Card] search :: String -> IO String search q = do let tokens = lexx q - tree <- liftIO (executeBottomQuery tokens) + --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 @@ -29,6 +32,7 @@ executeQuery :: Tree -> [Card] executeQuery (Holder cards) = cards executeQuery (Funct Union leftToken rightToken) = executeQuery leftToken `union` executeQuery rightToken executeQuery (Funct Intersect leftToken rightToken) = executeQuery leftToken `intersect` executeQuery rightToken +executeQuery (Funct Minus leftToken rightToken) = executeQuery leftToken `minus` executeQuery rightToken executeQuery _ = error $ "Not implemented!" @@ -36,11 +40,12 @@ buildHtml :: [Card] -> String buildHtml = concatMap cardToHtml ---Fancy trickery to move the IO to outer, in order to allow all the combinatorics to not have to live in IO land :) + executeBottomQuery :: Token -> IO Tree -executeBottomQuery (Queri (SuperType value)) = do - temp <- superType value - return $ Holder temp +executeBottomQuery (Queri (SuperType value)) = superType value +executeBottomQuery (Queri (CMCLT value)) = cmcLT value +executeBottomQuery (Queri (CMCMT value)) = cmcMT value +executeBottomQuery (Queri (CMCEQ value)) = cmcEQ value executeBottomQuery (Queri _) = error $ "Not implemented yet" executeBottomQuery (Func operator left right) = do left <- executeBottomQuery left @@ -52,10 +57,10 @@ executeBottomQuery (Func operator left right) = do cardToHtml :: Card -> String -cardToHtml (Card id_ scryfall_id lang name (Just oracle_text) (Just image_uri) type_line) = +cardToHtml (Card id_ scryfall_id lang name (Just oracle_text) (Just image_uri) type_line cmc) = "

" ++ unpack name ++ "

" ++ ""++ - "

" ++ unpack oracle_text ++ "

"++"

" + "

" ++ unpack oracle_text ++ "

"++" " cardToHtml _ = "

Could not load that card

" \ No newline at end of file diff --git a/src/Config.hs b/src/Config.hs index 4905e22..ee811dc 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} module Config - ( getDataSeedPath, getDbPath + ( getDataSeedPath, getDbPath, getBulkDataLink ) where import Data.Aeson import Data.Text @@ -17,7 +17,8 @@ import GHC.IO.Exception data Config = Config{ dataseedpath :: String, - dbPath :: String + dbPath :: String, + bulkDataLink :: String } deriving (Show,Generic) instance FromJSON Config @@ -58,5 +59,9 @@ getDbPath ::IO (String) getDbPath = do dbPath <$> getConfig +getBulkDataLink :: IO (String) +getBulkDataLink = do + bulkDataLink <$> getConfig + extract :: IO (Maybe a) -> IO a extract = (>>= maybe (ioError $ userError "Could not read config!") return) diff --git a/src/DataFetcher.hs b/src/DataFetcher.hs new file mode 100644 index 0000000..bd24e4f --- /dev/null +++ b/src/DataFetcher.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +module DataFetcher + ( fetchData + ) where +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import qualified Data.ByteString.Lazy as B +import Config + +fetchData = do + link <- getBulkDataLink + + manager <- newManager tlsManagerSettings + + request <- parseRequest link + + r <- httpLbs request manager + + return $ responseBody r \ No newline at end of file diff --git a/src/Seed.hs b/src/Seed.hs index b994d4f..797b99d 100644 --- a/src/Seed.hs +++ b/src/Seed.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} module Seed - ( seedData + ( seedDataFile, seedDataWeb ) where import Data.Aeson ( eitherDecode, FromJSON, ToJSON ) @@ -13,6 +13,7 @@ import Database.SQLite.Simple import Config import GHC.Generics +import DataFetcher (fetchData) data ImageUris = ImageUris { small :: Text, normal :: Text, @@ -31,40 +32,53 @@ data Card = Card{ name :: Text, oracle_text :: Maybe Text, image_uris :: Maybe ImageUris, - type_line :: Text + type_line :: Maybe Text, + cmc :: Int } deriving (Show,Generic) instance FromJSON Card instance ToJSON Card instance ToRow Card where - toRow (Card object id lang name oracle_text (Just (ImageUris _ image_link _ _ _ _ )) type_line) = toRow (id, lang, name, oracle_text, image_link, type_line) - toRow (Card object id lang name oracle_text Nothing type_line) = toRow (id, lang, name, oracle_text, Nothing:: (Maybe Text), type_line) + 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) - - -getJSON :: String -> IO B.ByteString -getJSON file = B.readFile file - -insertCards :: Connection -> [Card] -> IO() -insertCards conn ((card):cards) = do - execute conn "INSERT INTO card (scryfall_id, lang, name, oracle_text, image_uri, type_line) VALUES (?,?,?,?,?,?)" card - insertCards conn cards - return () -insertCards conn [] = return () - -seedData :: IO () -seedData = do +seedDataFile :: IO () +seedDataFile = do -- Get JSON data and decode it + + d <- getDataSeedPath + + dat <- (eitherDecode <$> getJSON d) :: IO (Either String [Card]) + seedData dat + +seedDataWeb :: IO () +seedDataWeb = do + dat <- (eitherDecode <$> getJSONWeb) :: IO (Either String [Card]) + seedData dat - seedData <- getDataSeedPath + + +seedData d = do dbPath <- getDbPath - d <- (eitherDecode <$> getJSON seedData) :: IO (Either String [Card]) 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)" - + 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)" case d of Left err -> putStrLn err Right ps -> insertCards conn ps +getJSON :: String -> IO B.ByteString +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 () + diff --git a/src/Site/Static/index.html b/src/Site/Static/index.html index ad76060..103ed7d 100644 --- a/src/Site/Static/index.html +++ b/src/Site/Static/index.html @@ -8,7 +8,7 @@
- +