increase cardgen performance

.gitignore

@@ -27,3 +27,4 @@ cabal.project.local~
 .ghc.environment.*
 data/
 test_runs/
+dg.svg

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

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.
 

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
           ];

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

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)
 

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