fix cache folder bug

DraftGen.cabal

@@ -101,6 +101,7 @@ test-suite unit-tests
     , filepath
     , pretty-simple
     , sandwich
+    , transformers
     , unordered-containers
 
   ghc-options:    -threaded

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"
-            ];
-        });
       };
     };
 }

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,34 +21,37 @@ 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)
 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
   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)
+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] =

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

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