Version 0.1 finished

src/Algorithm/BaseQuery.hs

@@ -5,7 +5,10 @@ module Algorithm.BaseQuery
     cmcLT,
     cmcMT,
     cmcEQ,
-    Tree(..)
+    Tree(..),
+    CardFace(..),
+    ImageUris(..),
+    isLegal
     ) where
 import qualified Data.Text as T
 import Database.SQLite.Simple
@@ -14,6 +17,7 @@ import Data.Text (Text, isInfixOf)
 import Control.Monad.IO.Class (MonadIO(liftIO))
 import Algorithm.Lex (Operator)
 import GHC.Generics (Generic)
+import Web.Scotty (rescue)
 
 
 {- 
@@ -135,12 +139,12 @@ instance FromRow CardTypeLine where
 
 superType :: String -> IO Tree
 superType qry = do
-  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]
+  res <- runQuerySimple "select card.id, card_face.type_line 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 :: [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 ((CardTypeLine id_ type_line):cards) qry = if qry `isInfixOf` type_line then ID id_:typeLineFilter cards qry else typeLineFilter cards qry
 typeLineFilter [] _ = []
 --------------------------------------------------------------
 
@@ -166,4 +170,10 @@ cmcEQ value = do
   cards <- fetchCardsWithIds res
   return $ Holder cards
 
+isLegal :: String -> IO Tree
+isLegal qry = do
+  res <- runQueryNamed "select card.id from card inner join legalities where card.id = legalities.card_id and legalities.:val = legal" [":val" := qry] :: IO [ID]
+  cards <- fetchCardsWithIds res
+  return $ Holder cards
+  
 

src/Algorithm/Lex.hs

@@ -85,7 +85,8 @@ data QueryDef =
     Color String | 
     CMCLT Int | 
     CMCMT Int | 
-    CMCEQ Int 
+    CMCEQ Int |
+    IsLegal String
     deriving Show
 data Operator = 
     Union |
@@ -125,6 +126,7 @@ extractQueryDef ("CmcMT", value) = case readMaybe value :: Maybe Int of
 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 ("IsLegal", value) = Right $ IsLegal value 
 extractQueryDef (a,b) = Left $ ParseError $ "The following command is invalid " ++ show a
 
 extractOperator "union" = Union

src/Algorithm/Search.hs

@@ -12,8 +12,11 @@ import Data.Text (unpack)
 import Algorithm.Operator (union, intersect, minus)
 import Control.Monad.IO.Class
 import Data.Aeson.Encoding (value)
+import Data.Char (toLower)
+import qualified Data.Maybe
 
-
+--Probably a lot better way to do this, ex: reading from the database, but i want to avoid having IO everywhere
+formats = ["standard", "future", "historic", "gladiator", "pioneer", "explorer", "modern", "legacy", "pauper", "vintage", "penny", "commander", "brawl", "historicbrawl", "alchemy", "paupercommander", "duel", "oldschool", "premodern", "predh"]
 
 search :: String -> IO String
 search q = do
@@ -48,6 +51,7 @@ 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 (IsLegal value)) | map toLower value `elem` formats = isLegal $ map toLower value
 executeBottomQuery (Queri _) = error $ "Not implemented yet"
 executeBottomQuery (Func operator left right) = do
   left <- executeBottomQuery left
@@ -55,11 +59,24 @@ executeBottomQuery (Func operator left right) = do
   return $ Funct operator left right
 
 
-
-
-
 cardToHtml :: Card -> String
-cardToHtml (Card _ _ _ name (Just cmc) (Just oracle_text) type_line (Just mana_cost) _) =
+--Card with a single face!
-  "<div class=\"card\" style=\"text-align:center\"><h2>" ++ unpack name ++ "</h2>" ++
+cardToHtml (Card _ _ _ _ _ _ _ _ [cardFace]) = singleCardFaceHTML cardFace
-  "<p style=\"width:205px;margin: 0 auto;font-size:12;\">" ++ unpack oracle_text ++ "<p>"++" </div>"
+
-cardToHtml _ = "<h1>Could not load that card</h1>"
+--Multiface card!
+cardToHtml (Card _ _ _ _ _ _ _ _ cardFaces) = "<div style=\"text-align:center;\"><div style=\"display: inline-flex\">" ++ concatMap singleCardFaceHTML cardFaces ++"</div></div>"
+
+singleCardFaceHTML :: CardFace -> String
+singleCardFaceHTML (CardFace _ _ name cmc oracle_text type_line mana_cost (ImageUris _ _ _ image _ _ _ _)) =
+  "<div style=\"text-align:center;\">" ++
+    "<h2>" ++ unpack name ++ "</h2>" ++
+    "<img src=" ++ unpack image ++ " width=\"200px\"/>"++
+    "<p style=\"width:205px;margin: 5 auto;font-size:16;\">" ++  unpack (Data.Maybe.fromMaybe "" type_line) ++ "</p>"++
+    "<p style=\"width:205px;margin: 5 auto;font-size:12;\">" ++ unpack (Data.Maybe.fromMaybe "" oracle_text) ++ "</p>"++
+    "<p style=\"width:205px;margin: 5 auto;font-size:16;\">Mana cost: " ++  filter (`notElem` ['{','}']) (unpack (Data.Maybe.fromMaybe "" mana_cost)) ++ "</p>"++
+  " </div>"
+
+
+parseCMC :: Maybe Int -> String
+parseCMC (Just a) = show a
+parseCMC Nothing = ""

src/Seed.hs

@@ -161,12 +161,17 @@ seedData d = do
     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)"
+    execute_ conn "CREATE TABLE IF NOT EXISTS legalities (id INTEGER PRIMARY KEY, card_id 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)"
 
 
     case d of
         Left err -> putStrLn err
-        Right ps -> insertCards conn 0 0 ps
+        Right ps -> do
+            collectedCards <- collectCards conn 0 0 ps
+            fillDb conn collectedCards
+            return ()
+
+
 
 
 
@@ -179,52 +184,56 @@ getJSONWeb = fetchData
 
 ---------------------------------------------------------------------------------------------------------
 
-insertCards :: Connection -> Int -> Int -> [Card] -> IO()
+collectCards :: Connection -> Int -> Int -> [Card] -> IO ([DbCard], [Legalities], [(CardFace, ImageUris)])
 
 --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"] =
+collectCards 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
+    collectCards 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
+collectCards _ _ _ (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
+collectCards 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)]
+    --insertRows conn dbCard legalities [(cardFace, imageUris)]
-    insertCards conn (card_id + 1) (card_face_id + 1) cards
+    (dbCards, legalitiesRest, cfius) <- collectCards conn (card_id + 1) (card_face_id + 1) cards
+    return (dbCard:dbCards, legalities:legalitiesRest, (cardFace, imageUris):cfius)
 
 --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
+collectCards 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
+    --insertRows conn dbCard legalities cardFacesAndImageUris
-    insertCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards
+    (dbCards, legalitiesRest, cfius) <- collectCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards
+    return (dbCard:dbCards, legalities:legalitiesRest, cardFacesAndImageUris ++ cfius)
 
 --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
+collectCards 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
+    --insertRows conn dbCard legalities cardFacesAndImageUris
-    insertCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards
+    (dbCards, legalitiesRest, cfius) <- collectCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards
-
+    return (dbCard:dbCards, legalities:legalitiesRest, cardFacesAndImageUris ++ cfius)
-insertCards _ _ _  [] = return ()
 
+collectCards _ _ _  [] = return ([],[],[])
 
 
+-- Helper functions for collectCards
 
 
 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 _ _ _ [] = []
@@ -246,24 +255,31 @@ 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 _ _ [] = []
 
+---------------------------------------------------------------------------------------------------------------------------------------------------------------------
+
+fillDb :: Connection -> ([DbCard], [Legalities], [(CardFace, ImageUris)]) -> IO ()
+fillDb conn (dbCards, legalities, combo) = do
+    let (cardFaces, imageUris) = unzip combo
+    executeMany conn "INSERT INTO card (id, scryfall_id, lang, name, cmc, oracle_text, type_line, mana_cost ) VALUES (?,?,?,?,?,?,?,?)" dbCards
+    executeMany conn "INSERT INTO card_face (id, card_id, name, cmc, oracle_text, type_line, mana_cost) VALUES (?,?,?,?,?,?,?)" cardFaces
+    executeMany conn "INSERT INTO image_uris (card_face_id, small , normal , large , png , art_crop, border_crop) VALUES (?,?,?,?,?,?,?)" imageUris
+    executeMany 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
+-- 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
 
 
-insertRows :: Connection -> DbCard -> Legalities -> [(CardFace, ImageUris)] -> IO()
+-- insertCard :: Connection -> DbCard -> IO ()
-insertRows conn dbCard legalities face_uri = do
+-- insertCard conn card = do
-    mapM_  (insertCardFaceImageUris conn) face_uri
+--     execute conn "INSERT INTO card (id, scryfall_id, lang, name, cmc, oracle_text, type_line, mana_cost ) VALUES (?,?,?,?,?,?,?,?)" card
-    insertCard conn dbCard
-    insertLegalities conn legalities
 
-insertCardFaceImageUris :: Connection -> (CardFace, ImageUris) -> IO ()
+-- insertLegalities :: Connection -> Legalities -> IO ()
-insertCardFaceImageUris conn (cardFace, imageUris) = do
+-- insertLegalities conn legalities = do
-    execute conn "INSERT INTO card_face (id, card_id, name, cmc, oracle_text, type_line, mana_cost) VALUES (?,?,?,?,?,?,?)" cardFace
+--     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
-    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

src/Site/Static/index.html

@@ -2,13 +2,13 @@
 <html>
 <body>
 
-    <div>
+    <div style="text-align: center;">
-        <h1>This is a heading</h1>
+        <h1>TMagic the gathering search engine!</h1>
 
         <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"> 
+        <form style="text-align: center;" method="POST" action="/api/req"> 
             <textarea rows="5" cols="33" name="query"></textarea>
             <button type="submit">SHIP IT!</button>
         </form>