diff --git a/DraftGen.cabal b/DraftGen.cabal index 68c83f1..a3b89ac 100644 --- a/DraftGen.cabal +++ b/DraftGen.cabal @@ -101,6 +101,7 @@ test-suite unit-tests , filepath , pretty-simple , sandwich + , transformers , unordered-containers ghc-options: -threaded diff --git a/flake.nix b/flake.nix index 84758d9..5d49eae 100644 --- a/flake.nix +++ b/flake.nix @@ -24,7 +24,6 @@ pkgsStatic, ghcVersion, hpkgs, - hlib, system, self', ... @@ -87,17 +86,6 @@ packages.draftgen = pkgsStatic.haskell.packages."${ghcVersion}".callCabal2nix "DraftGen" ./. { inherit (self'.packages) dg-prelude; }; - packages.draftgen-static = hlib.overrideCabal (self'.packages.draftgen) (old: { - configureFlags = - (old.configureFlags or []) - ++ [ - "--ghc-option=-optl-static" - "--ghc-option=-split-sections" - "--extra-lib-dirs=${pkgsStatic.zlib}/lib" - "--extra-lib-dirs=${pkgsStatic.gmp6}/lib" - "--extra-lib-dirs=${pkgsStatic.libffi}/lib" - ]; - }); }; }; } diff --git a/src/DraftGen/File.hs b/src/DraftGen/File.hs index 24b0a32..40f95f4 100644 --- a/src/DraftGen/File.hs +++ b/src/DraftGen/File.hs @@ -7,9 +7,9 @@ Module for handling reading from and writing to files -} -module File (execute) where +module File (execute, run) where -import CLI +import CLI qualified import Control.Concurrent.Async qualified as Async import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) @@ -21,10 +21,10 @@ 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 Network.HTTP.Client qualified as Http +import Network.HTTP.Client.TLS qualified as Http import Paths_DraftGen qualified as Paths -import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory) +import System.Directory qualified as Filesystem import System.FilePath ((<.>), ()) import Text.Printf (printf) import Types (CardObj, PackConfig (..), SetDataObj (..), SetInfo (..), fileName, fromArgs) @@ -32,15 +32,18 @@ import Util (appName, landName, packName, tokenName) execute :: IO () execute = (either putStrLn pure <=< runExceptT) $ do - rawArgs <- liftIO $ unwrapRecord "" + rawArgs <- liftIO $ CLI.unwrapRecord "" args <- ExceptT . pure $ validateArgs rawArgs - let config = fromArgs args - ln = fileName config landName + run $ fromArgs args + +run :: MonadIO m => PackConfig -> ExceptT String m () +run config = do + let 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 + dataPath <- liftIO $ Filesystem.getXdgDirectory Filesystem.XdgData appName + liftIO $ Filesystem.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 @@ -48,7 +51,7 @@ execute = (either putStrLn pure <=< runExceptT) $ do 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) +validateArgs :: CLI.Args CLI.Unwrapped -> Either String (CLI.Args CLI.Unwrapped) validateArgs as | as.amount < 1 = Left "Error: amount is less than one" | as.commons < 0 = Left "Error: commons is negative" @@ -58,9 +61,9 @@ validateArgs as getFromCache :: MonadIO m => String -> ExceptT String m (HashSet CardObj) getFromCache set = do - cachePrefixPath <- liftIO $ getXdgDirectory XdgCache appName + cachePrefixPath <- liftIO $ Filesystem.getXdgDirectory Filesystem.XdgCache appName let filepath = cachePrefixPath set <.> "json" - setFileExists <- liftIO $ doesFileExist filepath + setFileExists <- liftIO $ Filesystem.doesFileExist filepath if setFileExists then ExceptT $ readCards filepath else do @@ -72,28 +75,30 @@ getFromCache set = do writeSet :: String -> HashSet CardObj -> IO () writeSet set cards = do - cachePathPrefix <- liftIO $ getXdgDirectory XdgCache appName + cachePathPrefix <- liftIO $ Filesystem.getXdgDirectory Filesystem.XdgCache appName + cacheDirectoryExists <- Filesystem.doesDirectoryExist cachePathPrefix + unless cacheDirectoryExists $ Filesystem.createDirectory cachePathPrefix Json.encodeFile (cachePathPrefix set <> ".json") cards -- Make a GET request to the scryfall API -getScryfall :: Manager -> String -> [(BS.ByteString, Maybe BS.ByteString)] -> IO (Response BSL.ByteString) +getScryfall :: Http.Manager -> String -> [(BS.ByteString, Maybe BS.ByteString)] -> IO (Http.Response BSL.ByteString) getScryfall manager url queryParams = do - req <- parseRequest url + req <- Http.parseRequest url let version = BS.pack $ showVersion Paths.version req' = req - { requestHeaders = + { Http.requestHeaders = [ ("Accept", "application/json") , ("User-Agent", "draftgen/" `BS.append` version) ] } - & setQueryString queryParams - httpLbs req' manager + & Http.setQueryString queryParams + Http.httpLbs req' 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 + manager <- liftIO $ Http.newManager Http.tlsManagerSettings setInfoRes <- liftIO $ getScryfall manager ("https://api.scryfall.com/sets" set) [] setInfo <- ExceptT . pure $ Json.eitherDecode @SetInfo setInfoRes.responseBody let pages :: [Int] = diff --git a/src/DraftGen/Types.hs b/src/DraftGen/Types.hs index 048c7e9..e817ed7 100644 --- a/src/DraftGen/Types.hs +++ b/src/DraftGen/Types.hs @@ -268,7 +268,14 @@ data SetDataObj = SetDataObj , cardData :: [CardObj] } deriving stock (Generic, Show) - deriving (FromJSON) via (ConfigJSON SnakeCase SetDataObj) + +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 diff --git a/test/src/Main.hs b/test/src/Main.hs index 0f9c27a..417c314 100644 --- a/test/src/Main.hs +++ b/test/src/Main.hs @@ -9,11 +9,14 @@ -} module Main where +import CLI import Control.Monad.Catch import Control.Monad.IO.Class +import Control.Monad.Trans.Except (runExceptT) import Data.Aeson qualified as Json import Data.HashSet (HashSet) import Data.HashSet qualified as HS +import File (run) import Generate (filterDesired, readCards) import System.FilePath import Test.Sandwich @@ -63,12 +66,27 @@ testFrameEffectInverse = encodeDecodeIsInverse CompassLandDfc testBorderColorInverse :: (MonadIO m, MonadThrow m) => m () testBorderColorInverse = encodeDecodeIsInverse ColorBlack +genPacks :: (MonadIO m, MonadThrow m) => m () +genPacks = runExceptT (run config) *> shouldBe True True + where + config = + PackConfig + { amount = 6 + , set = "fin" + , commons = 10 + , uncommons = 3 + , rareOrMythics = 1 + , mythicChance = Ratio 1 8 + , foilChance = Ratio 1 45 + } + basic :: TopSpec basic = describe "Unit tests" $ do it "filterDesired filters out undesired card types" testFilterDesired it "cardFace encode/decode are inverses" testCardFaceInverse it "frameEffect encode/decode are inverses" testFrameEffectInverse it "borderColor encode/decode are inverses" testBorderColorInverse + it "generates packs without throwing exceptions" genPacks main :: IO () main = runSandwichWithCommandLineArgs defaultOptions basic