mtgsearch/src/Algorithm/BaseQuery.hs

{-# LANGUAGE OverloadedStrings #-}
module Algorithm.BaseQuery
    ( superType,
    Card(..),
    cmcLT,
    cmcMT,
    cmcEQ,
    Tree(..),
    CardFace(..),
    ImageUris(..),
    isLegal
    ) 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)
import GHC.Generics (Generic)
import Web.Scotty (rescue)


{- 
In this module we handle the "bottom" requests, these are made using Joins with only the minimum amount of data needed 

Then the ID of the valid cards is used to fetch a full "Card" with all fields needed to show to the user
-}

data Tree = Funct Operator Tree Tree | Holder [Card]




data ImageUris = ImageUris
  Int
  Int
  T.Text
  T.Text
  T.Text
  T.Text
  T.Text
  T.Text

instance FromRow ImageUris where
  fromRow = ImageUris <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field


data TempCardFace = TempCardFace
  Int
  Int
  T.Text
  (Maybe Int)
  (Maybe T.Text)
  (Maybe T.Text)
  (Maybe T.Text)

instance FromRow TempCardFace where
  fromRow = TempCardFace <$> field <*> field <*> field <*> field <*> field <*> field <*> field


data TempCard = TempCard
  Int
  T.Text
  T.Text
  T.Text
  (Maybe Int)
  (Maybe T.Text)
  T.Text
  (Maybe T.Text)
instance FromRow TempCard where
  fromRow = TempCard <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field

data CardFace = CardFace
  Int
  Int
  T.Text
  (Maybe Int)
  (Maybe T.Text)
  (Maybe T.Text)
  (Maybe T.Text)
  ImageUris


data Card = Card
  Int
  T.Text
  T.Text
  T.Text
  (Maybe Int)
  (Maybe T.Text)
  T.Text
  (Maybe T.Text)
  [CardFace]


instance Eq Card where
  (==) (Card id_ _ _ _ _ _ _ _ _ ) (Card id2_ _ _ _ _ _ _ _ _ ) = id_ == id2_


fetchCardsWithIds :: [ID] -> IO [Card]
fetchCardsWithIds = mapM fetchCardWithId

fetchCardWithId :: ID -> IO Card
fetchCardWithId (ID id) = do
  tempCardFaces <- runQueryNamed "select id, card_id, name, cmc, oracle_text, type_line, mana_cost from card_face where card_id = :val" [":val" := id] :: IO [TempCardFace]
  --We are fetchinig based on primary key, so we know the result is a single data
  [TempCard id scryfall_id lang name cmc oracle_text type_line mana_cost] <- runQueryNamed "select id, scryfall_id, lang, name, cmc, oracle_text,type_line, mana_cost from card where id = :val" [":val" := id] :: IO [TempCard]
  cardFaces <- mapM fetchImageUris tempCardFaces
  return $ Card id scryfall_id lang name cmc oracle_text type_line mana_cost cardFaces

fetchImageUris :: TempCardFace -> IO (CardFace)
fetchImageUris (TempCardFace id card_id name cmc oracle_text type_line mana_cost) = do
  --We can do this only because a ImageUri row is 1:1 with CardFace in the database
  [imageUri] <- runQueryNamed "select id, card_face_id, small, normal, large, png, art_crop, border_crop from image_uris where card_face_id = :val" [":val" := id] :: IO [ImageUris]
  return $ CardFace id card_id name cmc oracle_text type_line mana_cost imageUri



runQuerySimple :: (FromRow a) =>  Query -> IO [a]
runQuerySimple str = do
  dbPath <- getDbPath
  conn <- open dbPath
  query_ conn str ::(FromRow a) =>  IO [a];

runQueryNamed ::(FromRow a) =>  Query -> [NamedParam] -> IO [a]
runQueryNamed qur parm = do
  dbPath <- getDbPath
  conn <- open dbPath
  queryNamed conn qur parm :: (FromRow a) =>  IO [a]


--------------------------------------------------------------
data CardTypeLine = CardTypeLine
  Int
  T.Text

instance FromRow CardTypeLine where
  fromRow = CardTypeLine <$> field <*> field

superType :: String -> IO Tree
superType qry = do
  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 ((CardTypeLine id_ type_line):cards) qry = if qry `isInfixOf` type_line then ID id_:typeLineFilter cards qry else typeLineFilter cards qry
typeLineFilter [] _ = []
--------------------------------------------------------------

newtype ID = ID Int
instance FromRow ID where
  fromRow = ID <$> field

cmcLT :: Int -> IO Tree
cmcLT value = do
  res <- runQueryNamed "select card.id from card inner join card_face where card.id = card_face.card_id and (card.cmc < :val or card_face.cmc < :val)" [":val" := value] :: IO [ID]
  cards <- fetchCardsWithIds res
  return $ Holder cards

cmcMT :: Int -> IO Tree
cmcMT value = do
  res <- runQueryNamed "select card.id from card inner join card_face where card.id = card_face.card_id and (card.cmc > :val or card_face.cmc > :val)" [":val" := value] :: IO [ID]
  cards <- fetchCardsWithIds res
  return $ Holder cards

cmcEQ :: Int -> IO Tree
cmcEQ value = do
  res <- runQueryNamed "select card.id from card inner join card_face where card.id = card_face.card_id and (card.cmc = :val or card_face.cmc = :val)" [":val" := value] :: IO [ID]
  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