Skip to content

Commit

Permalink
Use prettyprinter
Browse files Browse the repository at this point in the history
  • Loading branch information
@newhoggy
newhoggy committed Feb 6, 2023
1 parent d86a701 commit a362193
Show file tree
Hide file tree
Showing 14 changed files with 138 additions and 109 deletions.
10 changes: 5 additions & 5 deletions app/App/Commands/Debug/S3/Cp.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,9 +16,8 @@ import Control.Monad.Trans.AWS (envOverride, setEndpoint)
import Data.ByteString (ByteString)
import Data.Generics.Product.Any (the)
import Data.Monoid (Dual(Dual), Endo(Endo))
import HaskellWorks.CabalCache.AppError (AwsError(..), displayAwsError)
import HaskellWorks.CabalCache.AppError (AwsError(..))
import HaskellWorks.CabalCache.Error (CopyFailed(..), ExitFailure(..), UnsupportedUri)
import HaskellWorks.CabalCache.Show (tshow)
import Network.URI (parseURI)

import qualified App.Commands.Options.Types as Z
Expand All @@ -27,6 +26,7 @@ import qualified Data.Text as T
import qualified HaskellWorks.CabalCache.AWS.Env as AWS
import qualified HaskellWorks.CabalCache.AWS.S3 as AWS
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified HaskellWorks.CabalCache.Pretty as PP
import qualified Network.AWS as AWS
import qualified Network.AWS.Data as AWS
import qualified Options.Applicative as OA
Expand All @@ -52,11 +52,11 @@ runCp opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do

AWS.copyS3Uri envAws srcUri dstUri
& do OO.catch @AwsError \e -> do
CIO.hPutStrLn IO.stderr $ "Copy failed: " <> displayAwsError e
CIO.hPutLn IO.stderr $ "Copy failed: " <> PP.show e
& do OO.catch @CopyFailed \CopyFailed -> do
CIO.hPutStrLn IO.stderr $ "Copy failed"
CIO.hPutLn IO.stderr $ "Copy failed"
& do OO.catch @UnsupportedUri \e -> do
CIO.hPutStrLn IO.stderr $ "Unsupported uri: " <> tshow e
CIO.hPutLn IO.stderr $ "Unsupported uri: " <> PP.show e

optsCp :: OA.Parser CpOptions
optsCp = CpOptions
Expand Down
14 changes: 8 additions & 6 deletions app/App/Commands/Plan.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,9 +14,9 @@ import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Generics.Product.Any (the)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure(..))
import HaskellWorks.CabalCache.Location (Location (..), (<.>), (</>))
import HaskellWorks.CabalCache.Show (tshow)
import HaskellWorks.CabalCache.Version (archiveVersion)
import Options.Applicative (Parser, Mod, CommandFields)

Expand All @@ -29,8 +29,10 @@ import qualified Data.Text as T
import qualified HaskellWorks.CabalCache.Core as Z
import qualified HaskellWorks.CabalCache.Hash as H
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified HaskellWorks.CabalCache.Pretty as PP
import qualified Network.AWS.Data as AWS
import qualified Options.Applicative as OA
import qualified Prettyprinter as PP
import qualified System.IO as IO

{- HLINT ignore "Monoid law, left identity" -}
Expand All @@ -45,14 +47,14 @@ runPlan opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
let versionedArchiveUris = archiveUris & each %~ (</> archiveVersion)
let outputFile = opts ^. the @"outputFile"

CIO.putStrLn $ "Store path: " <> AWS.toText storePath
CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash
CIO.putStrLn $ "Archive URIs: " <> tshow archiveUris
CIO.putStrLn $ "Archive version: " <> archiveVersion
CIO.putLn $ "Store path: " <> PP.text storePath
CIO.putLn $ "Store path hash: " <> PP.text storePathHash
CIO.putLn $ "Archive URIs: " <> PP.show archiveUris
CIO.putLn $ "Archive version: " <> PP.pretty @Text archiveVersion

planJson <- Z.loadPlan (opts ^. the @"path" </> opts ^. the @"buildPath")
& do OO.catch @DecodeError \e -> do
CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e
CIO.hPutLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> PP.show e
OO.throw ExitFailure

packages <- liftIO $ Z.getPackages storePath planJson
Expand Down
59 changes: 30 additions & 29 deletions app/App/Commands/SyncFromArchive.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,13 +26,12 @@ import Data.Maybe (fromMaybe)
import Data.Monoid (Dual(Dual), Endo(Endo))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, displayHttpError)
import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..))
import HaskellWorks.CabalCache.Error (DecodeError(..), ExitFailure(..), InvalidUrl(..), NotFound, UnsupportedUri(..))
import HaskellWorks.CabalCache.IO.Lazy (readFirstAvailableResource)
import HaskellWorks.CabalCache.IO.Tar (ArchiveError(..))
import HaskellWorks.CabalCache.Location (toLocation, (<.>), (</>), Location)
import HaskellWorks.CabalCache.Metadata (loadMetadata)
import HaskellWorks.CabalCache.Show (tshow)
import HaskellWorks.CabalCache.Version (archiveVersion)
import Options.Applicative (CommandFields, Mod, Parser)
import Options.Applicative.NonEmpty (some1)
Expand All @@ -58,11 +57,13 @@ import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg
import qualified HaskellWorks.CabalCache.Hash as H
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified HaskellWorks.CabalCache.IO.Tar as IO
import qualified HaskellWorks.CabalCache.Pretty as PP
import qualified HaskellWorks.CabalCache.Store as M
import qualified HaskellWorks.CabalCache.Types as Z
import qualified Network.AWS as AWS
import qualified Network.AWS.Data as AWS
import qualified Options.Applicative as OA
import qualified Prettyprinter as PP
import qualified System.Directory as IO
import qualified System.IO as IO
import qualified System.IO.Temp as IO
Expand All @@ -88,23 +89,23 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
let maxRetries = opts ^. the @"maxRetries"
let ignorePackages = opts ^. the @"ignorePackages"

CIO.putStrLn $ "Store path: " <> AWS.toText storePath
CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash
CIO.putLn $ "Store path: " <> PP.text storePath
CIO.putLn $ "Store path hash: " <> PP.text storePathHash
forM_ archiveUris $ \archiveUri -> do
CIO.putStrLn $ "Archive URI: " <> AWS.toText archiveUri
CIO.putStrLn $ "Archive version: " <> archiveVersion
CIO.putStrLn $ "Threads: " <> tshow threads
CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel
CIO.putLn $ "Archive URI: " <> PP.text archiveUri
CIO.putLn $ "Archive version: " <> PP.pretty @Text archiveVersion
CIO.putLn $ "Threads: " <> PP.show threads
CIO.putLn $ "AWS Log level: " <> PP.show awsLogLevel

OO.catchAndExitFailure @ExitFailure do
planJson <- Z.loadPlan (opts ^. the @"path" </> opts ^. the @"buildPath")
& do OO.catch @DecodeError \e -> do
CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e
CIO.hPutLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> PP.show e
OO.throw ExitFailure

compilerContext <- Z.mkCompilerContext planJson
& do OO.catch @Text \e -> do
CIO.hPutStrLn IO.stderr e
CIO.hPutLn IO.stderr $ PP.pretty e
OO.throw ExitFailure

liftIO $ GhcPkg.testAvailability compilerContext
Expand All @@ -118,15 +119,15 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
let storeCompilerPackageDbPath = storeCompilerPath </> "package.db"
let storeCompilerLibPath = storeCompilerPath </> "lib"

CIO.putStrLn "Creating store directories"
CIO.putLn "Creating store directories"
liftIO $ createDirectoryIfMissing True storePath
liftIO $ createDirectoryIfMissing True storeCompilerPath
liftIO $ createDirectoryIfMissing True storeCompilerLibPath

storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath

unless storeCompilerPackageDbPathExists do
CIO.putStrLn "Package DB missing. Creating Package DB"
CIO.putLn "Package DB missing. Creating Package DB"
liftIO $ GhcPkg.init compilerContext storeCompilerPackageDbPath

packages <- liftIO $ Z.getPackages storePath planJson
Expand All @@ -152,7 +153,7 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
OO.recoverOrVoid @DQ.DownloadStatus do
pInfo <- pure (M.lookup packageId pInfos)
& do OO.onNothing do
CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId
CIO.hPutLn IO.stderr $ "Warning: Invalid package id: " <> PP.pretty packageId
DQ.succeed

let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz"
Expand All @@ -165,15 +166,15 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do

package <- pure (M.lookup packageId planPackages)
& do OO.onNothing do
CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageName
CIO.hPutLn IO.stderr $ "Warning: package not found" <> PP.pretty packageId
DQ.succeed

when (skippable package) do
CIO.putStrLn $ "Skipping: " <> packageName
CIO.putLn $ "Skipping: " <> PP.pretty packageId
DQ.succeed

when (packageName `S.member` ignorePackages) do
CIO.putStrLn $ "Ignoring: " <> packageName
CIO.putLn $ "Ignoring: " <> PP.text packageName
DQ.fail

when storeDirectoryExists DQ.succeed
Expand All @@ -183,35 +184,35 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do

(existingArchiveFileContents, existingArchiveFile) <- readFirstAvailableResource envAws locations maxRetries
& do OO.catch @AwsError \e -> do
CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayAwsError e
CIO.putLn $ "Unable to download any of: " <> PP.show locations <> " because: " <> PP.show e
DQ.fail
& do OO.catch @HttpError \e -> do
CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayHttpError e
CIO.putLn $ "Unable to download any of: " <> PP.show locations <> " because: " <> PP.show e
DQ.fail
& do OO.catch @NotFound \_ -> do
CIO.putStrLn $ "Not found: " <> tshow locations
CIO.putLn $ "Not found: " <> PP.show locations
DQ.fail
& do OO.catch @InvalidUrl \(InvalidUrl url' reason') -> do
CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason'
& do OO.catch @InvalidUrl \(InvalidUrl url reason) -> do
CIO.hPutLn IO.stderr $ "Invalid URL: " <> PP.pretty url <> ", " <> PP.pretty reason
DQ.fail
& do OO.catch @UnsupportedUri \e -> do
CIO.hPutStrLn IO.stderr $ tshow e
CIO.hPutLn IO.stderr $ PP.show e
DQ.fail

CIO.putStrLn $ "Extracting: " <> AWS.toText existingArchiveFile
CIO.putLn $ "Extracting: " <> PP.text existingArchiveFile

let tempArchiveFile = tempPath </> archiveBaseName
liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents

IO.extractTar tempArchiveFile storePath
& do OO.catch @ArchiveError \(ArchiveError reason') -> do
CIO.putStrLn $ "Unable to extract tar at " <> tshow tempArchiveFile <> " because: " <> reason'
& do OO.catch @ArchiveError \(ArchiveError reason) -> do
CIO.putLn $ "Unable to extract tar at " <> PP.show tempArchiveFile <> " because: " <> PP.pretty reason
DQ.fail

meta <- loadMetadata packageStorePath
oldStorePath <- pure (Map.lookup "store-path" meta)
& do OO.onNothing do
CIO.putStrLn "store-path is missing from Metadata"
CIO.putLn "store-path is missing from Metadata"
DQ.fail

let Z.Tagged conf _ = Z.confPath pInfo
Expand All @@ -226,13 +227,13 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do

DQ.succeed

CIO.putStrLn "Recaching package database"
CIO.putLn "Recaching package database"

liftIO $ GhcPkg.recache compilerContext storeCompilerPackageDbPath

failures <- liftIO $ STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"

forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId
forM_ failures $ \packageId -> CIO.hPutLn IO.stderr $ "Failed to download: " <> PP.text packageId

ensureStorePathCleanup :: ()
=> MonadIO m
Expand All @@ -246,7 +247,7 @@ ensureStorePathCleanup packageStorePath =
case downloadStatus of
DQ.DownloadFailure -> M.cleanupStorePath packageStorePath
DQ.DownloadSuccess ->
CIO.hPutStrLn IO.stdout $ "Successfully cleaned up store path: " <> tshow packageStorePath
CIO.hPutLn IO.stdout $ "Successfully cleaned up store path: " <> PP.show packageStorePath
OO.throw downloadStatus

optsSyncFromArchive :: Parser SyncFromArchiveOptions
Expand Down
Loading

0 comments on commit a362193

Please sign in to comment.