Added a fetcher for data, added a lot more operators. Need to add a ReadMe on how this is used2

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"
 }

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

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

package.yaml

@@ -27,7 +27,8 @@ dependencies:
 - sqlite-simple
 - scotty
 - directory
-
+- http-client
+- http-client-tls
 ghc-options:
 - -Wall
 - -Wcompat

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]
+runQuerySimple :: Query -> IO [Card]
-superType qry = do
+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];
+  query_ conn str :: IO [Card];
-  return $ typeLineFilter res (T.pack qry)
+
+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 [] _ = []
+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

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 $ strip $ stripFront $ clearIllegalCharacters qur
-    let collected = clearRepeatedSpaces $ collector qur
+    let parenthesises = matchParenthesis collected 0
-    let parenthesises = trace (show $ matchParenthesis collected 0) (matchParenthesis collected 0)
+    let (parenthesisFixed, parenthesis) = fixSeparators collected parenthesises
-    let (parenthesisFixed, parenthesis) = trace (show $ fixSeparators collected parenthesises) 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 QueryDef = 
-data Operator = Union | Intersect deriving Show
+    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)))

src/Algorithm/Operator.hs

@@ -1,14 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Algorithm.Operator
     ( union,
-    intersect
+    intersect,
+    minus
     ) where
 
 
-union :: [a] -> [a] -> [a]
+union :: Eq a => [a] -> [a] -> [a]
-union res1 res2 = res1 ++ res2
+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 [] _ = []
+minus :: Eq a => [a] -> [a] -> [a]
+minus (a:as) bs | a `notElem` bs = a:minus as bs
+minus (_:as) bs = minus as bs
+minus [] _ = []

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 
+executeBottomQuery (Queri (SuperType value)) = superType value
-  temp <- superType value
+executeBottomQuery (Queri (CMCLT value)) = cmcLT value
-  return $ Holder temp
+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) =
   "<div class=\"card\" style=\"text-align:center\"><h2>" ++ unpack name ++ "</h2>" ++
   "<img src=" ++ unpack image_uri ++ " width=\"200px\"/>"++
-  "<p>" ++ unpack oracle_text ++ "<p>"++" </div>"
+  "<p style=\"width:200px\">" ++ unpack oracle_text ++ "<p>"++" </div>"
 
 
 cardToHtml _ = "<h1>Could not load that card</h1>"

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)

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

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 (Just (ImageUris _ image_link _ _ _ _ )) type_line cmc) = 
-    toRow (Card object id lang name oracle_text Nothing type_line) = toRow (id, lang, name, oracle_text, Nothing:: (Maybe Text), type_line)
+        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)
 
-
+seedDataFile :: IO ()
-
+seedDataFile = do
-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
     -- 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 ()
+

src/Site/Static/index.html

@@ -8,7 +8,7 @@
 
 
 <form method="POST" action="/api/req"> 
-    <input name="query"/>
+    <textarea rows="5" cols="33" name="query"></textarea>
     <button type="submit">SHIP IT!</button>
 </form>