diff --git a/app/Main.hs b/app/Main.hs index 4582179..0b8dd60 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,7 @@ - module Main (main) where import System.Environment import Site.Host +import Seed ( seedData ) import Lib diff --git a/mtgsearch.cabal b/mtgsearch.cabal index 792c208..da3c219 100644 --- a/mtgsearch.cabal +++ b/mtgsearch.cabal @@ -25,10 +25,13 @@ source-repository head library exposed-modules: + Algorithm.BaseQuery Algorithm.Lex + Algorithm.Operator Algorithm.Search Config Lib + Seed Site.Host other-modules: Paths_mtgsearch diff --git a/src/Algorithm/BaseQuery.hs b/src/Algorithm/BaseQuery.hs new file mode 100644 index 0000000..e71af69 --- /dev/null +++ b/src/Algorithm/BaseQuery.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Algorithm.BaseQuery + ( superType, + Card(..) + ) 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)) +data Card = Card + Int + T.Text + T.Text + T.Text + (Maybe T.Text) + (Maybe T.Text) + T.Text + deriving (Show) + +instance FromRow Card where + fromRow = Card <$> 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) + + +superType :: String -> IO [Card] +superType qry = 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) + +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 [] _ = [] \ No newline at end of file diff --git a/src/Algorithm/Lex.hs b/src/Algorithm/Lex.hs index e46bbb8..8f91b2b 100644 --- a/src/Algorithm/Lex.hs +++ b/src/Algorithm/Lex.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Algorithm.Lex ( lexx - , Token(..)) where + , Token(..) + , QueryDef(..) + , Operator(..)) where import Prelude hiding (lex) import Debug.Trace import Data.ByteString (count, putStr) @@ -19,6 +21,8 @@ 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 @@ -54,31 +58,23 @@ findClosing (x:xs) stackCount count = findClosing xs stackCount (count+1) findClosing [] _ _ = error "Unequal number of parenthesis" -data Token = Seperated String Token Token | Queri String String deriving Show +data Token = Func Operator Token Token | Queri QueryDef deriving Show +data QueryDef = SuperType String| Color String deriving Show +data Operator = Union deriving Show seperator :: [String] -> [(Int, Int)] -> Token seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of - " ":operator:" ":"(":rightRest -> Seperated operator (seperator (take (end-start) rest) points) (seperator (init rightRest) points) + " ":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) +extractQueryDef :: (String, String) -> QueryDef +extractQueryDef ("SuperType", value) = SuperType value +extractQueryDef _ = error $ "This command was not valid" - -seperator [name, " ", value, ")"] points = Queri name value -seperator a _ = error "Something went wrong tokenizing the input!" - - - ---This one works, but not for lines! - --- seperator :: [String] -> [(Int, Int)] -> Seperated --- seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of --- " ":operator:" ":"(":rightRest -> Seperated operator (seperator (take (end-start) rest) points) (seperator (init rightRest) points) --- [] -> seperator (take (end-start) rest) points --- a ->trace (show a) error "This is not allowed" - - - - +extractOperator "union" = Union +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 new file mode 100644 index 0000000..176b782 --- /dev/null +++ b/src/Algorithm/Operator.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +module Algorithm.Operator + ( union + ) where + + +union :: IO [a] -> IO [a] -> [a] +union res1 res2 = res1 ++ res2 \ No newline at end of file diff --git a/src/Algorithm/Search.hs b/src/Algorithm/Search.hs index 2fa9a6a..d444b0a 100644 --- a/src/Algorithm/Search.hs +++ b/src/Algorithm/Search.hs @@ -3,37 +3,49 @@ module Algorithm.Search ( search ) where import Database.SQLite.Simple +import Algorithm.BaseQuery import Config (getDbPath) -import Web.Scotty.Internal.Types -import Control.Monad import qualified Data.Text as T import Algorithm.Lex +import Control.Monad +import Data.Text (unpack) +import Algorithm.Operator (union) +import Control.Monad.IO.Class -data Card = Card Int T.Text T.Text deriving (Show) - -instance FromRow Card where - fromRow = Card <$> field <*> field <*> field - -instance ToRow Card where - - toRow (Card id_ str image_uri) = toRow (id_, str, image_uri) search :: String -> IO String search q = do let tokens = lexx q - simpleSearch q + queryRes <- executeQuery tokens + let hyperText = buildHtml queryRes + return hyperText + + + +executeQuery :: Token -> IO [Card] +executeQuery (Queri bottom) = executeBottomQuery bottom +executeQuery (Func Union leftToken rightToken) = executeQuery leftToken `union` executeQuery rightToken +executeQuery _ = error $ "Not implemented!" -simpleSearch :: String -> IO String -simpleSearch q = do - dbPath <- getDbPath - conn <- open dbPath - res <- queryNamed conn "select id, name, image_uri from card where name like :name" [":name" := ("%"++q++"%")] :: IO [Card] - let hyperText = buildHtml res - return hyperText buildHtml :: [Card] -> String buildHtml = concatMap cardToHtml + + +executeBottomQuery :: QueryDef -> IO [Card] +executeBottomQuery (SuperType value) = superType value +executeBottomQuery _ = error $ "Not implemented yet" + + + + cardToHtml :: Card -> String -cardToHtml (Card id name image_uri) = "

" ++ show name ++ "

" ++ "
" \ No newline at end of file +cardToHtml (Card id_ scryfall_id lang name (Just oracle_text) (Just image_uri) type_line) = + "

" ++ unpack name ++ "

" ++ + ""++ + "

" ++ unpack oracle_text ++ "

"++"

" + + +cardToHtml _ = "

Could not load that card

" \ No newline at end of file diff --git a/src/Lib.hs b/src/Lib.hs index dbeeeb2..fd62150 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,68 +1,4 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} module Lib - ( seedData + ( ) where -import Data.Aeson -import Data.Text - -import qualified Data.ByteString.Lazy as B - -import Database.SQLite.Simple - -import Config - -import GHC.Generics -data ImageUris = ImageUris { - small :: Text, - normal :: Text, - large :: Text, - png :: Text, - art_crop :: Text, - border_crop :: Text -}deriving (Show,Generic) -instance FromJSON ImageUris -instance ToJSON ImageUris - -data Card = Card{ - object :: Text, - id :: Text, - lang :: Text, - name :: Text, - oracle_text :: Maybe Text, - image_uris :: Maybe ImageUris -} 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 _ _ _ _ ))) = toRow (id, lang, name, oracle_text, image_link) - toRow (Card object id lang name oracle_text Nothing) = toRow (id, lang, name, oracle_text, pack "Nothing") - - - -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) VALUES (?,?,?,?,?)" card - insertCards conn cards - return () -insertCards conn [] = return () - -seedData :: IO () -seedData = do - -- Get JSON data and decode it - - seedData <- getDataSeedPath - 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)" - - - case d of - Left err -> putStrLn err - Right ps -> insertCards conn ps - diff --git a/src/Seed.hs b/src/Seed.hs new file mode 100644 index 0000000..b994d4f --- /dev/null +++ b/src/Seed.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +module Seed + ( seedData + ) where + +import Data.Aeson ( eitherDecode, FromJSON, ToJSON ) +import Data.Text + +import qualified Data.ByteString.Lazy as B + +import Database.SQLite.Simple + +import Config + +import GHC.Generics +data ImageUris = ImageUris { + small :: Text, + normal :: Text, + large :: Text, + png :: Text, + art_crop :: Text, + border_crop :: Text +}deriving (Show,Generic) +instance FromJSON ImageUris +instance ToJSON ImageUris + +data Card = Card{ + object :: Text, + id :: Text, + lang :: Text, + name :: Text, + oracle_text :: Maybe Text, + image_uris :: Maybe ImageUris, + type_line :: Text +} 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) + + + +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 + + seedData <- getDataSeedPath + 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)" + + + case d of + Left err -> putStrLn err + Right ps -> insertCards conn ps + diff --git a/src/Site/Host.hs b/src/Site/Host.hs index 7adbffc..a0fad80 100644 --- a/src/Site/Host.hs +++ b/src/Site/Host.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Site.Host ( host ) where @@ -15,8 +14,8 @@ host = scotty 3000 $ do post "/api/req" $ do query <- param "query" - liftIO (putStrLn $ "\nOutput! " ++ show (lexx query)) - cards <- liftIO (search query) + --liftIO (putStrLn $ "\nOutput! " ++ show (lexx query)) + --cards <- liftIO (search query) result <- liftIO (search query) html $ mconcat ["

", pack result, "

"]