minor stuff

 * relude-1.0
 * progress bar is now threadsafe
 * better auth error messages

Author: amesgen

.hlint.yaml

@@ -218,12 +218,22 @@
 - warn:
     lhs: "f <$> nonEmpty x"
     rhs: viaNonEmpty f x
+- warn:
+    lhs: partitionEithers . map f
+    rhs: partitionWith f
+- warn:
+    lhs: partitionEithers $ map f x
+    rhs: partitionWith f x
 - warn:
     lhs: "f >>= guard"
     rhs: guardM f
 - warn:
-    lhs: "guard =<< f"
+    lhs: guard =<< f
     rhs: guardM f
+- warn:
+    lhs: forever
+    note: "'forever' is loosely typed and may hide errors"
+    rhs: infinitely
 - warn:
     lhs: "whenM (not <$> x)"
     rhs: unlessM x
@@ -309,7 +319,7 @@
     lhs: "maybe (return ()) f =<< m"
     rhs: whenJustM m f
 - warn:
-    lhs: "maybe pass        f =<< m"
+    lhs: maybe pass        f =<< m
     rhs: whenJustM m f
 - warn:
     lhs: "m >>= maybe (pure ())   f"
@@ -1118,11 +1128,6 @@
     name: "Use 'Natural' from Relude"
     note: "'Natural' is already exported from Relude"
     rhs: Natural
-- warn:
-    lhs: System.IO.Handle
-    name: "Use 'Handle' from Relude"
-    note: "'Handle' is already exported from Relude"
-    rhs: Handle
 - warn:
     lhs: System.IO.IOMode
     name: "Use 'IOMode' from Relude"
@@ -1148,26 +1153,6 @@
     name: "Use 'ReadWriteMode' from Relude"
     note: "'ReadWriteMode' is already exported from Relude"
     rhs: ReadWriteMode
-- warn:
-    lhs: System.IO.stderr
-    name: "Use 'stderr' from Relude"
-    note: "'stderr' is already exported from Relude"
-    rhs: stderr
-- warn:
-    lhs: System.IO.stdin
-    name: "Use 'stdin' from Relude"
-    note: "'stdin' is already exported from Relude"
-    rhs: stdin
-- warn:
-    lhs: System.IO.stdout
-    name: "Use 'stdout' from Relude"
-    note: "'stdout' is already exported from Relude"
-    rhs: stdout
-- warn:
-    lhs: System.IO.withFile
-    name: "Use 'withFile' from Relude"
-    note: "'withFile' is already exported from Relude"
-    rhs: withFile
 - warn:
     lhs: Data.Ord.Down
     name: "Use 'Down' from Relude"
@@ -1802,7 +1787,7 @@
     lhs: Data.Function.on
     name: "Use 'on' from Relude"
     note: "'on' is already exported from Relude"
-    rhs: "on"
+    rhs: 'on'
 - warn:
     lhs: Data.Bifunctor.Bifunctor
     name: "Use 'Bifunctor' from Relude"
@@ -2095,6 +2080,66 @@
     name: "Use 'getLine' from Relude"
     note: "'getLine' is already exported from Relude"
     rhs: getLine
+- warn:
+    lhs: System.IO.hFlush
+    name: "Use 'hFlush' from Relude"
+    note: "'hFlush' is already exported from Relude"
+    rhs: hFlush
+- warn:
+    lhs: System.IO.hIsEOF
+    name: "Use 'hIsEOF' from Relude"
+    note: "'hIsEOF' is already exported from Relude"
+    rhs: hIsEOF
+- warn:
+    lhs: System.IO.hSetBuffering
+    name: "Use 'hSetBuffering' from Relude"
+    note: "'hSetBuffering' is already exported from Relude"
+    rhs: hSetBuffering
+- warn:
+    lhs: System.IO.hGetBuffering
+    name: "Use 'hGetBuffering' from Relude"
+    note: "'hGetBuffering' is already exported from Relude"
+    rhs: hGetBuffering
+- warn:
+    lhs: System.IO.Handle
+    name: "Use 'Handle' from Relude"
+    note: "'Handle' is already exported from Relude"
+    rhs: Handle
+- warn:
+    lhs: System.IO.stdin
+    name: "Use 'stdin' from Relude"
+    note: "'stdin' is already exported from Relude"
+    rhs: stdin
+- warn:
+    lhs: System.IO.stdout
+    name: "Use 'stdout' from Relude"
+    note: "'stdout' is already exported from Relude"
+    rhs: stdout
+- warn:
+    lhs: System.IO.stderr
+    name: "Use 'stderr' from Relude"
+    note: "'stderr' is already exported from Relude"
+    rhs: stderr
+- warn:
+    lhs: System.IO.withFile
+    name: "Use 'withFile' from Relude"
+    note: "'withFile' is already exported from Relude"
+    rhs: withFile
+- warn:
+    lhs: System.IO.BufferMode
+    name: "Use 'BufferMode' from Relude"
+    note: "'BufferMode' is already exported from Relude"
+    rhs: BufferMode
+- warn:
+    lhs: System.Environment.getArgs
+    name: "Use 'getArgs' from Relude"
+    note: "'getArgs' is already exported from Relude"
+    rhs: getArgs
+- warn:
+    lhs: System.Environment.lookupEnv
+    name: "Use 'lookupEnv' from Relude"
+    note: "'lookupEnv' is already exported from Relude"
+    rhs: lookupEnv
 - warn:
     lhs: Data.List.genericDrop
     name: "Use 'genericDrop' from Relude"
@@ -3095,6 +3140,36 @@
     name: "'liftIO' is not needed"
     note: "If you import 'putLBSLn' from Relude, it's already lifted"
     rhs: putLBSLn
+- warn:
+    lhs: "(liftIO (hFlush x))"
+    name: "'liftIO' is not needed"
+    note: "If you import 'hFlush' from Relude, it's already lifted"
+    rhs: hFlush
+- warn:
+    lhs: "(liftIO (hIsEOF x))"
+    name: "'liftIO' is not needed"
+    note: "If you import 'hIsEOF' from Relude, it's already lifted"
+    rhs: hIsEOF
+- warn:
+    lhs: "(liftIO (hSetBuffering x y))"
+    name: "'liftIO' is not needed"
+    note: "If you import 'hSetBuffering' from Relude, it's already lifted"
+    rhs: hSetBuffering
+- warn:
+    lhs: "(liftIO (hGetBuffering x))"
+    name: "'liftIO' is not needed"
+    note: "If you import 'hGetBuffering' from Relude, it's already lifted"
+    rhs: hGetBuffering
+- warn:
+    lhs: "(liftIO (getArgs ))"
+    name: "'liftIO' is not needed"
+    note: "If you import 'getArgs' from Relude, it's already lifted"
+    rhs: getArgs
+- warn:
+    lhs: "(liftIO (lookupEnv x))"
+    name: "'liftIO' is not needed"
+    note: "If you import 'lookupEnv' from Relude, it's already lifted"
+    rhs: lookupEnv
 - hint:
     lhs: "fmap (bimap f g)"
     note: "Use `bimapF` from `Relude.Extra.Bifunctor`"
@@ -3135,6 +3210,10 @@
     lhs: toEnum
     note: "`toEnum` from `Prelude` is a pure function but it may throw exception. Consider using `safeToEnum` from `Relude.Extra.Enum` instead."
     rhs: safeToEnum
+- hint:
+    lhs: sum xs / length xs
+    note: "Use `average` from `Relude.Extra.Foldable`"
+    rhs: average xs
 - hint:
     lhs: "\\a -> (a, a)"
     note: "Use `dup` from `Relude.Extra.Tuple`"

README.md

@@ -13,6 +13,7 @@ Some Minecraft stuff as a CLI:
  - Manage CurseForge mods
     - install
     - update
+    - deduplicate
  - Install CurseForge modpacks
 
 ## ToC

cabal.project

@@ -1,4 +1,4 @@
 packages: .
 
 with-compiler: ghc-8.10.4
-index-state: 2021-02-14T00:00:00Z
+index-state: 2021-03-22T00:00:00Z

hellsmack.cabal

@@ -21,7 +21,7 @@ flag use-openssl
   manual: True
 
 common commons
-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies DerivingVia DuplicateRecordFields EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving ImportQualifiedPost InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns NoStarIsType OverloadedLabels OverloadedStrings PackageImports PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving StandaloneKindSignatures StrictData TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UnliftedNewtypes ViewPatterns
+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies DerivingVia DuplicateRecordFields EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving ImportQualifiedPost InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns NoStarIsType OverloadedLabels OverloadedStrings PackageImports PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving StandaloneKindSignatures StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UnliftedNewtypes ViewPatterns
   ghc-options: -Wall -Werror -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wmissing-deriving-strategies -Wunused-packages -Wwarn=unused-packages -fhide-source-paths -fno-warn-name-shadowing
   default-language: Haskell2010
 
@@ -36,10 +36,7 @@ library
   build-tool-depends:
       autoexporter:autoexporter >= 1.1
   build-depends:
-      relude >= 0.7
-    , bytestring >= 0.10
-    , text >= 1.2
-    , containers >= 0.6
+      relude >= 1.0
     , transformers >= 0.5
     , random >= 1.2
     , filepath >= 1.4
@@ -52,15 +49,15 @@ library
     , aeson >= 1.5
     , lens-aeson >= 1.1
     , time >= 1.9
-    , yasi >= 0.1
+    , yasi >= 0.1.1
     , binary >= 0.8
     , exceptions >= 0.10
     , unliftio >= 0.2
     , conduit >= 1.3
     , conduit-extra >= 1.3
     , binary-conduit >= 1.3
     , broadcast-chan-conduit >= 0.2
-    , lens >= 4.19
+    , lens >= 5.0
     , generic-lens >= 2.0
     , pcre2 >= 1.1
     , cryptohash-sha1 >= 0.11

src/HellSmack/Curse.hs

@@ -117,14 +117,14 @@ downloadFullModpack ModpackInstallOptions {..} = do
           \ModLoaderInfo {id} -> logInfo $ [i|mod loader: ${}|] $ C.formatWith [C.bold] id
 
         let (optionalFileIds, requiredFileIds) =
-              manifest ^. #files
-                <&> do \f -> (chosen %~ (^. #fileID)) . bool Left Right (f ^. #required) $ f
-                & partitionEithers
+              manifest ^. #files & partitionWith \f ->
+                (chosen %~ (^. #fileID)) . bool Left Right (f ^. #required) $ f
 
         logInfo $ [i|fetching metadata of $show mods|] $ length requiredFileIds
         files <- getAddonFilesByFileIds requiredFileIds <&> (^.. each . folded)
 
-        logInfo "downloading mods"
+        let modSize = showBytes' $ sumOf (each . #fileLength) files
+        logInfo $ [i|downloading mods ($modSize)|]
         let modDir = outDir </> [reldir|mods|]
         ensureDir modDir
         stepWise (withGenericProgress (length files)) \step ->
@@ -290,11 +290,9 @@ findInCurseDB inputs = do
     M.fromList . (^.. #exactMatches . each . to ((^. #file . #packageFingerprint) &&& identity))
       <$> getFingerprintMatches (fst <$> fps)
   let result@(unknown, _) =
-        fps <&> do
-          \(fp, path) -> case fpms ^? ix fp of
-            Just FingerprintMatch {..} -> Right (id, file, path)
-            Nothing -> Left path
-          & partitionEithers
+        fps & partitionWith \(fp, path) -> case fpms ^? ix fp of
+          Just FingerprintMatch {..} -> Right (id, file, path)
+          Nothing -> Left path
   unless (null unknown) do
     logWarn $ [i|these ${show} files are not present in the CurseForge mod database:|] $ length unknown
     for_ unknown $ logWarn . [i| - ${}|] . toFilePath

src/HellSmack/Forge.hs

@@ -345,10 +345,9 @@ preprocess fv vvm im = do
     Left _ -> do
       logInfo "starting forge preprocessing"
       let (embedded, downloadable) =
-            partitionEithers $
-              im ^. #libraries <&> \case
-                l | l & has do #downloads . #artifact . _Just . #url . only "" -> Left l
-                l -> Right l
+            im ^. #libraries & partitionWith \case
+              l | l & has do #downloads . #artifact . _Just . #url . only "" -> Left l
+              l -> Right l
       libDir <- siehs @DirConfig #libraryDir
       forOf_ (each . #downloads . #artifact . _Just . #path) embedded \fp ->
         extractFromInstaller' fv ([reldir|maven|] </> fp) (libDir </> fp)

src/HellSmack/Util/Terminal.hs

@@ -37,7 +37,7 @@ import Text.Printf (printf)
 import UnliftIO.Async
 import UnliftIO.Concurrent
 import UnliftIO.Exception
-import UnliftIO.IO
+import UnliftIO.IO (hIsTerminalDevice)
 
 showBytes :: Integral a => a -> a -> Text
 showBytes (fromIntegral -> ref :: Double) (fromIntegral -> a :: Double) =
@@ -119,15 +119,15 @@ withProgress showN' maxCount cb =
           Nothing -> 80
       countRef <- newIORef 0
       start <- currentTime
-      let withProgressBar = withAsyncWithUnmask \unmask -> forever do
+      let withProgressBar = withAsyncWithUnmask \unmask -> infinitely do
             count <- readIORef countRef
             diff <- diffAbsoluteTime <$> currentTime <*> pure start
             let p = round @Double $ fromIntegral count / fromIntegral maxCount * fromIntegral barLength
                 fW c = C.formatWith [c]
                 bar = fW C.green (T.replicate p "#") <> fW C.blue (T.replicate (barLength - p) "-")
             putTextLn $ barTxt diff bar count
             unmask (threadDelay printTickMicros) `finally` clearLastLines 1
-      withProgressBar \_ -> cb $ modifyIORef' countRef
+      withProgressBar \_ -> cb $ atomicModifyIORef'_ countRef
     False -> cb $ const pass
   where
     barTxt diff bar count = [i|[$diffTxt] $bar ${} / ${}|] (showN count) (showN maxCount)

src/HellSmack/Yggdrasil/API.hs

@@ -30,7 +30,13 @@ data YggdrasilException = YggdrasilException
     cause :: Maybe Text
   }
   deriving stock (Show, Generic)
-  deriving anyclass (Exception, FromJSON)
+  deriving anyclass (FromJSON)
+
+instance Exception YggdrasilException where
+  displayException YggdrasilException {..} =
+    [i|Yggdrasil authentication error: $errorMessage ($error$causeMsg)|]
+    where
+      causeMsg = maybe "" [iT|, caused by ${}|] cause
 
 newtype AccessToken = AccessToken {unAccessToken :: Text}
   deriving stock (Show, Eq, Generic)

src/Main.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoMonoLocalBinds #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 
@@ -21,14 +20,14 @@ import HellSmack.Yggdrasil
 import Main.Utf8 (withUtf8)
 import Options.Applicative qualified as OA
 import Path.IO
-import System.Exit hiding (exitFailure)
+import System.Exit (ExitCode (..))
 import UnliftIO.Exception
 
 main :: IO ()
 main =
   withUtf8 . displayErrors $ do
     -- TODO use some open product thingy (cf. jrec branch)
-    getArgs >>= \CLI {..} -> do
+    getCLI >>= \CLI {..} -> do
       dataDir <- maybe defaultDataDir makeSomeAbsolute dataDir
       ensureDir dataDir
       let authPath = dataDir </> [relfile|auth.json|]
@@ -145,8 +144,8 @@ data ModOptions
   | ModDeduplicate Curse.ModDeduplicateOptions
   deriving stock (Show, Generic)
 
-getArgs :: IO CLI
-getArgs = OA.execParser $ OA.info (OA.helper <*> ver <*> cliParser) OA.fullDesc
+getCLI :: IO CLI
+getCLI = OA.execParser $ OA.info (OA.helper <*> ver <*> cliParser) OA.fullDesc
   where
     ver = OA.infoOption (toString verStr) do
       OA.short 'V' <> OA.long "version" <> OA.help "Print version"

src/Prelude.hs

@@ -6,6 +6,5 @@ import Data.Generics.Labels as P ()
 import Data.Generics.Wrapped as P
 import Path as P hiding ((<.>))
 import Relude as P hiding (uncons, (??))
-import Relude.Extra.Enum as P
 import Relude.Extra.Tuple as P
 import Yasi as P