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 oracle_text ++ "
"++"
" ++ unpack oracle_text ++ "
"++" " cardToHtml _ = "