diff --git a/.gitignore b/.gitignore index a435f90..a0a5bfd 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,4 @@ cabal.project.local~ .ghc.environment.* data/ test_runs/ +dg.svg diff --git a/DraftGen.cabal b/DraftGen.cabal index f7bb7d9..0f643b6 100644 --- a/DraftGen.cabal +++ b/DraftGen.cabal @@ -65,6 +65,7 @@ library build-depends: , aeson + , async , base ^>=4.19.2.0 , bytestring , containers @@ -80,6 +81,9 @@ library , transformers , unordered-containers + other-modules: + Paths_DraftGen + hs-source-dirs: src/DraftGen test-suite unit-tests diff --git a/README.md b/README.md index 6898df6..6eca7ae 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ An MTG booster pack generator for [Tabletop Simulator](https://store.steampowered.com/app/286160/Tabletop_Simulator/). # Documentation -![options](https://i.imgur.com/WDUyeUa.png) +Use `--help` for documentation. DraftGen lets you generate booster packs for MTG. The default options are set to simulate the rules and drop rates of regular booster packs. The default card set to generate packs from is the latest core set. These options can be changed by passing arguments through the command line. All arguments are listed in the help section `dg --help`. DraftGen will print the paths where the resulting json files are written depending upon your platform. diff --git a/flake.nix b/flake.nix index 70afc60..8bc48d2 100644 --- a/flake.nix +++ b/flake.nix @@ -46,17 +46,20 @@ }; devShells.default = let hpkgs = pkgs.haskell.packages.ghc98; - tools = with hpkgs; [ - cabal-fmt - cabal-install - fourmolu - ghc - ghc-prof-flamegraph - ghcid - pkgs.haskell-language-server - pkgs.nixd - profiteur - ]; + tools = with hpkgs; + [ + cabal-fmt + cabal-install + fourmolu + ghc + ghc-prof-flamegraph + ghcid + profiteur + ] + ++ (with pkgs; [ + haskell-language-server + nixd + ]); libraries = [ pkgs.zlib ]; diff --git a/profile.sh b/profile.sh new file mode 100755 index 0000000..60fc9a1 --- /dev/null +++ b/profile.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env sh + + +GHC_PROFILING_FLAGS="-fprof-auto -rtsopts" + +cabal build --enable-profiling --ghc-options="$GHC_PROFILING_FLAGS" + +time ./dist-newstyle/build/x86_64-linux/ghc-9.8.4/DraftGen-1.5.2.0/x/dg/build/dg/dg +RTS -p -RTS "$@" + +ghc-prof-flamegraph dg.prof + +firefox dg.svg diff --git a/src/DraftGen/CLI.hs b/src/DraftGen/CLI.hs index 48d4714..200408d 100644 --- a/src/DraftGen/CLI.hs +++ b/src/DraftGen/CLI.hs @@ -44,8 +44,6 @@ data Args w = Args , rares :: w ::: Int "1" "Amount of rares in pack" , mythicChance :: w ::: Ratio "1/8" "Chance of rare being mythic, value given as ratio" , foilChance :: w ::: Ratio "1/45" "Chance of one common being a foil of any rarity, value given as ratio (where 1/45 means 1 in 45)" - , downloadCards :: w ::: Bool "False" "Update card cache when generating packs" - , getCard :: w ::: Maybe String "Ignores all other arguments and generates a pack containing the one specific card" } deriving stock (Generic) diff --git a/src/DraftGen/File.hs b/src/DraftGen/File.hs index 58014dc..24b0a32 100644 --- a/src/DraftGen/File.hs +++ b/src/DraftGen/File.hs @@ -2,29 +2,50 @@ Module : File License : GNU GPL, version 3 or above Maintainer : skykanin <3789764+skykanin@users.noreply.github.com> - Stability : alpha + Stability : stable Portability : portable Module for handling reading from and writing to files -} module File (execute) where -import CLI (Args (..), Unwrapped, unwrapRecord) -import Control.Monad.IO.Class (liftIO) +import CLI +import Control.Concurrent.Async qualified as Async +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) -import Data.Aeson (eitherDecode, encodeFile) -import Data.ByteString.Lazy qualified as B +import Data.Aeson qualified as Json +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as BSL import Data.HashSet (HashSet) -import Encode (encodeCard, encodePacks) -import Generate (findCard, genLands, genPacks, genTokens, readCards) +import Data.HashSet qualified as HS +import Data.Version (showVersion) +import Encode (encodePacks) +import Generate (genLands, genPacks, genTokens) import Network.HTTP.Client import Network.HTTP.Client.TLS +import Paths_DraftGen qualified as Paths import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory) -import System.FilePath (()) +import System.FilePath ((<.>), ()) import Text.Printf (printf) -import Types (BulkDataObj, CardObj, fromArgs) -import Types qualified -import Util (appName, cardCacheName, fileName, landName, packName, tokenName) +import Types (CardObj, PackConfig (..), SetDataObj (..), SetInfo (..), fileName, fromArgs) +import Util (appName, landName, packName, tokenName) + +execute :: IO () +execute = (either putStrLn pure <=< runExceptT) $ do + rawArgs <- liftIO $ unwrapRecord "" + args <- ExceptT . pure $ validateArgs rawArgs + let config = fromArgs args + ln = fileName config landName + pn = fileName config packName + tn = fileName config tokenName + cards <- getFromCache config.set + dataPath <- liftIO $ getXdgDirectory XdgData appName + liftIO $ createDirectoryIfMissing True dataPath + selectedCards <- liftIO $ genPacks config cards + liftIO $ Json.encodeFile (dataPath tn) $ encodePacks $ genTokens config cards + liftIO $ Json.encodeFile (dataPath ln) $ encodePacks $ genLands config cards + liftIO $ Json.encodeFile (dataPath pn) $ encodePacks selectedCards + liftIO $ printf "Packs generated at: %s\nLands at: %s\nTokens at: %s" (dataPath pn) (dataPath ln) (dataPath tn) -- | Check that integer arguments aren't negative validateArgs :: Args Unwrapped -> Either String (Args Unwrapped) @@ -35,78 +56,60 @@ validateArgs as | as.rares < 0 = Left "Error: rares is negative" | otherwise = Right as -execute :: IO () -execute = (either print pure =<<) $ - runExceptT $ do - x <- liftIO $ unwrapRecord "" - args <- ExceptT $ pure $ validateArgs x - cachePath <- liftIO $ getXdgDirectory XdgCache appName - _ <- liftIO $ createDirectoryIfMissing True cachePath - cardCache <- - ExceptT . getFromCache args.downloadCards $ cachePath cardCacheName - cards <- ExceptT $ readCards cardCache - -- If argument is passed to a card search otherwise generate packs - case args.getCard of - Just query -> liftIO $ searchCard query cards - Nothing -> do - let config = fromArgs args - ln = fileName config landName - pn = fileName config packName - tn = fileName config tokenName - dataPath <- liftIO $ getXdgDirectory XdgData appName - _ <- liftIO $ createDirectoryIfMissing True dataPath - selectedCards <- liftIO $ genPacks config cards - _ <- liftIO $ encodeFile (dataPath tn) $ encodePacks $ genTokens config cards - _ <- liftIO $ encodeFile (dataPath ln) $ encodePacks $ genLands config cards - _ <- liftIO $ encodeFile (dataPath pn) $ encodePacks selectedCards - liftIO $ printf "Packs generated at: %s\nLands at: %s\nTokens at: %s" (dataPath pn) (dataPath ln) (dataPath tn) +getFromCache :: MonadIO m => String -> ExceptT String m (HashSet CardObj) +getFromCache set = do + cachePrefixPath <- liftIO $ getXdgDirectory XdgCache appName + let filepath = cachePrefixPath set <.> "json" + setFileExists <- liftIO $ doesFileExist filepath + if setFileExists + then ExceptT $ readCards filepath + else do + cards <- fetchSet set + liftIO $ writeSet set cards + pure cards + where + readCards = (fmap . fmap) HS.fromList . liftIO . Json.eitherDecodeFileStrict --- | Find card and write to file if it exists -searchCard :: String -> HashSet CardObj -> IO () -searchCard query cards = do - case findCard query cards of - Nothing -> putStrLn "Card not found" - Just card -> do - dataPath <- liftIO $ getXdgDirectory XdgData appName - let cardObj = encodeCard card - filePath = dataPath query <> ".json" - encodeFile filePath cardObj - printf "Card generated at: %s" filePath +writeSet :: String -> HashSet CardObj -> IO () +writeSet set cards = do + cachePathPrefix <- liftIO $ getXdgDirectory XdgCache appName + Json.encodeFile (cachePathPrefix set <> ".json") cards --- | If card cache already exists return them unless a flush is forced otherwise fetch them from scryfall -getFromCache :: Bool -> FilePath -> IO (Either String FilePath) -getFromCache force cardPath = doesFileExist cardPath >>= choice force - where - choice toForce cardsExists - | toForce = updateCache - | cardsExists = pure $ Right cardPath - | otherwise = updateCache - where - msg = putStrLn "Updating cache..." - updateCache = msg *> getLatestCards cardPath +-- Make a GET request to the scryfall API +getScryfall :: Manager -> String -> [(BS.ByteString, Maybe BS.ByteString)] -> IO (Response BSL.ByteString) +getScryfall manager url queryParams = do + req <- parseRequest url + let version = BS.pack $ showVersion Paths.version + req' = + req + { requestHeaders = + [ ("Accept", "application/json") + , ("User-Agent", "draftgen/" `BS.append` version) + ] + } + & setQueryString queryParams + httpLbs req' manager --- | Get the latest card set from scryfall and write it to a json file -getLatestCards :: FilePath -> IO (Either String FilePath) -getLatestCards cardPath = do - manager <- newManager tlsManagerSettings - response <- get manager "https://api.scryfall.com/bulk-data/default-cards" - print response.responseBody - let eCards :: Either String BulkDataObj - eCards = eitherDecode response.responseBody - case eCards of - Left err -> pure $ Left err - Right cardData -> do - cardBinData <- get manager cardData.downloadUri - B.writeFile cardPath cardBinData.responseBody - pure $ Right cardPath - where - get manager url = do - request <- parseRequest $ "GET " <> url - let request' = - request - { requestHeaders = - [ ("Accept", "application/json") - , ("User-Agent", "draftgen/1.5.2.0") - ] - } - httpLbs request' manager +-- Fetch all cards from a given set through scryfall +fetchSet :: MonadIO m => String -> ExceptT String m (HashSet CardObj) +fetchSet set = do + manager <- liftIO $ newManager tlsManagerSettings + setInfoRes <- liftIO $ getScryfall manager ("https://api.scryfall.com/sets" set) [] + setInfo <- ExceptT . pure $ Json.eitherDecode @SetInfo setInfoRes.responseBody + let pages :: [Int] = + enumFromTo 1 $ ceiling $ fromIntegral @_ @Double setInfo.cardCount / 175 + getSetData page = + getScryfall + manager + "https://api.scryfall.com/cards/search" + [ ("include_extras", Just "true") + , ("order", Just "set") + , ("include_multilingual", Just "false") + , ("include_variations", Just "false") + , ("unique", Just "prints") + , ("q", Just $ "e:" `BS.append` BS.pack set) + , ("page", Just . BS.pack $ show page) + ] + results <- liftIO $ Async.mapConcurrently getSetData pages + cards <- ExceptT . pure $ concatMap (.cardData) <$> traverse (Json.eitherDecode @SetDataObj . (.responseBody)) results + pure $ HS.fromList cards diff --git a/src/DraftGen/Types.hs b/src/DraftGen/Types.hs index dbdb91f..db4282b 100644 --- a/src/DraftGen/Types.hs +++ b/src/DraftGen/Types.hs @@ -15,6 +15,8 @@ module Types , CardFace (..) , CardObj (..) , BulkDataObj (..) + , SetInfo (..) + , SetDataObj (..) , CardImgObj (..) , ObjType (..) , TransformObj (..) @@ -23,6 +25,7 @@ module Types , TTSObj (..) , BorderColor (..) , fromArgs + , fileName ) where @@ -50,6 +53,8 @@ import Data.Hashable (Hashable) import Data.Sequence (Seq) import Data.Sequence qualified as Seq import GHC.Generics (Generic) +import Text.Printf (printf) +import Util (packName, snakeCase) data PackConfig = PackConfig { amount :: Int @@ -62,8 +67,14 @@ data PackConfig = PackConfig } deriving stock (Generic, Show) +-- | Produce filename with set and pack amount information +fileName :: PackConfig -> String -> String +fileName cfg name + | name == packName = printf "%d%s%s.json" cfg.amount cfg.set name + | otherwise = printf "%s%s.json" cfg.set name + fromArgs :: Args Unwrapped -> PackConfig -fromArgs (Args s a c uc r mc fc _ _) = PackConfig a s c uc r mc fc +fromArgs (Args s a c uc r mc fc) = PackConfig a s c uc r mc fc -- Lowercase string toLowerCase :: String -> String @@ -74,6 +85,9 @@ data Rarity = Common | Uncommon | Rare | Mythic | Special | Bonus instance Hashable Rarity +instance ToJSON Rarity where + toJSON = genericToJSON defaultOptions {constructorTagModifier = toLowerCase} + instance FromJSON Rarity where parseJSON = genericParseJSON @@ -88,7 +102,7 @@ data UriObj = UriObj , png :: String } deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON) + deriving anyclass (FromJSON, ToJSON) instance Hashable UriObj @@ -126,6 +140,13 @@ data FrameEffect instance Hashable FrameEffect +instance ToJSON FrameEffect where + toJSON = + genericToJSON + defaultOptions + { constructorTagModifier = toLowerCase + } + instance FromJSON FrameEffect where parseJSON = genericParseJSON @@ -140,6 +161,9 @@ data CardFace = CardFace deriving stock (Eq, Generic, Show) deriving anyclass (Hashable) +instance ToJSON CardFace where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = snakeCase} + instance FromJSON CardFace where parseJSON = withObject "CardFace" $ \v -> CardFace <$> v .: "name" <*> v .:? "image_uris" @@ -172,6 +196,13 @@ instance Eq CardObj where cardObjA == cardObjB = cardObjA.name == cardObjB.name +instance ToJSON CardObj where + toJSON = + genericToJSON + defaultOptions + { fieldLabelModifier = snakeCase + } + instance FromJSON CardObj where parseJSON = withObject "CardObj" $ \v -> CardObj @@ -204,6 +235,13 @@ data BorderColor deriving stock (Eq, Generic, Show) deriving anyclass (Hashable) +instance ToJSON BorderColor where + toJSON = + genericToJSON + defaultOptions + { constructorTagModifier = toLowerCase . drop 5 + } + instance FromJSON BorderColor where parseJSON = genericParseJSON @@ -227,6 +265,42 @@ instance FromJSON BulkDataObj where <*> v .: "name" <*> v .: "download_uri" +data SetInfo = SetInfo + { id :: String + , code :: String + , searchUri :: String + , releasedAt :: String + , setType :: String + , cardCount :: Int + } + deriving stock (Generic, Show) + +instance FromJSON SetInfo where + parseJSON = withObject "SetInfo" $ \v -> + SetInfo + <$> v .: "id" + <*> v .: "code" + <*> v .: "search_uri" + <*> v .: "released_at" + <*> v .: "set_type" + <*> v .: "card_count" + +data SetDataObj = SetDataObj + { object :: String + , totalCards :: Int + , hasMore :: Bool + , cardData :: [CardObj] + } + deriving stock (Generic, Show) + +instance FromJSON SetDataObj where + parseJSON = withObject "SetDataObj" $ \v -> + SetDataObj + <$> v .: "object" + <*> v .: "total_cards" + <*> v .: "has_more" + <*> v .: "data" + toObject :: Seq CardImgObj -> Value toObject = Object . go 1 M.empty where diff --git a/src/DraftGen/Util.hs b/src/DraftGen/Util.hs index 8b3eda0..26a2ae5 100644 --- a/src/DraftGen/Util.hs +++ b/src/DraftGen/Util.hs @@ -10,16 +10,31 @@ module Util ( appName , cardCacheName - , fileName , landName , packName + , snakeCase , tokenName ) where -import Text.Printf (printf) -import Types (PackConfig) -import Types qualified +import Data.Char + +snakeCase :: String -> String +snakeCase = symbCase '_' + +-- | Generic casing for symbol separated names +symbCase :: Char -> (String -> String) +symbCase sym = u . applyFirst toLower + where + u [] = [] + u (x : xs) + | isUpper x = sym : toLower x : u xs + | otherwise = x : u xs + +applyFirst :: (Char -> Char) -> String -> String +applyFirst _ [] = [] +applyFirst f [x] = [f x] +applyFirst f (x : xs) = f x : xs appName :: FilePath appName = "DraftGen" @@ -35,9 +50,3 @@ packName = "packs" tokenName :: FilePath tokenName = "tokens" - --- | Produce filename with set and pack amount information -fileName :: PackConfig -> String -> String -fileName cfg name - | name == packName = printf "%d%s%s.json" cfg.amount cfg.set name - | otherwise = printf "%s%s.json" cfg.set name