sak-0.1.2.6: src/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main ( main ) where

import           Compression
import           Compression.Level
import           Control.Concurrent.ParallelIO.Global (parallel_, stopGlobalPool)
import           Control.Monad                        (forM_)
import qualified Data.ByteString.Lazy                 as BSL
import           Data.Semigroup                       ((<>))
import           Detect
import           Options.Applicative
import           System.Directory                     (getSymbolicLinkTarget, pathIsSymbolicLink)
import           Version                              (allVersionsString)

reifyPath :: FilePath -> IO FilePath
reifyPath fp = do
    isSym <- pathIsSymbolicLink fp
    if isSym
        then getSymbolicLinkTarget fp
        else pure fp

data Command = Decompress !FilePath !(Maybe FilePath)
    | Compress !FilePath !FilePath !CompressionLevel
    | Recompress !FilePath !CompressionLevel
    | Transcode !FilePath !FilePath !CompressionLevel
    | Verify !FilePath
    | Matrix !FilePath !CompressionLevel
    | Info ![FilePath]

forceBSL :: BSL.ByteString -> IO ()
forceBSL = (`seq` mempty) . last . BSL.toChunks

recompressFile :: CompressionLevel
               -> FilePath
               -> IO ()
recompressFile lvl inp = do
    enc <- detectFileCompression inp
    pre <- case enc of
        BZip -> do { contents <- BSL.readFile inp
                   ; toDecompressor enc contents <$ forceBSL contents
                   }
        _ -> do { res <- toFileDecompressor enc inp
                ; forceBSL res
                ; pure res
                }
    let guessSz = case enc of
            Lzip -> Just $ 8 * fromIntegral (BSL.length pre)
            _    -> Nothing
    BSL.writeFile inp $ toCompressor enc lvl guessSz pre

decompressFile :: FilePath -- ^ Compressed file
               -> FilePath -- ^ Output
               -> IO ()
decompressFile inp o = BSL.writeFile o =<< f inp
    where f = toFileDecompressor (detectCompression inp)

decompressDetectFile :: FilePath -- ^ Compressed file
                     -> FilePath -- ^ Output
                     -> IO ()
decompressDetectFile inp o = do
    f <- toFileDecompressor <$> (detectFileCompression inp)
    BSL.writeFile o =<< (f inp)

compressFile :: CompressionLevel
             -> FilePath -- ^ Input file
             -> FilePath -- ^ Compressed output
             -> IO ()
compressFile lvl inp o = BSL.writeFile o =<< f inp
    where f = toFileCompressor (detectCompression o) lvl

compressMatrix :: CompressionLevel
               -> FilePath
               -> Compression
               -> IO ()
compressMatrix lvl inp c =
    BSL.writeFile (inp ++ ext c) =<< toFileCompressor c lvl inp

run :: Command -> IO ()
run (Recompress i lvl)          = recompressFile lvl =<< reifyPath i
run (Decompress i Nothing)      = flip decompressFile (uncompressedExt i) =<< reifyPath i
run (Decompress i (Just o))     = flip decompressDetectFile o =<< reifyPath i
run (Compress i o lvl)          = flip (compressFile lvl) o =<< reifyPath i
run (Transcode i o lvl)         = do
    cO <- detectFileCompression o
    guessSz <- case cO of
        Lzip -> Just . (8*) . fromIntegral <$> fileSize i
        _    -> pure Nothing
    BSL.writeFile o . toCompressor cO lvl guessSz =<< toFileDecompressor (detectCompression i) =<< reifyPath i
run (Verify i)                  = check (detectCompression i) =<< BSL.readFile =<< reifyPath i
run (Matrix inp lvl)            =
    parallel_ (compressMatrix lvl inp <$> [Lzma .. Lz4]) *>
    stopGlobalPool
run (Info fps)                  =
    forM_ fps $ \fp ->
        putStr (fp ++ ": ") *>
        (print =<< detectFileCompression fp)

fileCompletions :: HasCompleter f => Mod f a
fileCompletions = completer (bashCompleter "file -o plusdirs")

inpFile :: Parser FilePath
inpFile = fileHelp "Input file"

infoFile :: Parser Command
infoFile = Info <$> some (fileHelp "Archive")

verify :: Parser Command
verify = Verify <$> inpFile

compressionLevel :: Parser CompressionLevel
compressionLevel =
        compressCustom
    <|> compressBest
    <|> compressFast
    <|> flag Default Default mempty

compressCustom :: Parser CompressionLevel
compressCustom =
    Custom <$>
        option auto
        (long "compression-level"
        <> short 'l'
        <> metavar "LVL"
        <> help "Compression level (usually 0-9)"
        <> completer (listCompleter (show <$> [(0::Int)..22]))
        )

compressBest :: Parser CompressionLevel
compressBest =
    flag' Best (long "best")

compressFast :: Parser CompressionLevel
compressFast =
    flag' Fastest (long "fastest")

transcode :: Parser Command
transcode = Transcode
    <$> inpFile
    <*> fileHelp "Output"
    <*> compressionLevel

decompress :: Parser Command
decompress = Decompress
    <$> fileHelp "File to decompress"
    <*> optional outFile

outFile :: Parser FilePath
outFile = fileHelp "Decompressed output"

matrix :: Parser Command
matrix = Matrix
    <$> fileHelp "File to compress"
    <*> compressionLevel

recompress :: Parser Command
recompress = Recompress
    <$> fileHelp "File to recompress"
    <*> compressionLevel

compress :: Parser Command
compress = Compress
    <$> fileHelp "File to compress"
    <*> fileHelp "Compressed output"
    <*> compressionLevel

fileHelp :: String -> Parser FilePath
fileHelp helpTxt =
    argument str
    (metavar "FILE"
    <> fileCompletions
    <> help helpTxt)

cmd :: Parser Command
cmd = hsubparser
    (command "decompress" (info decompress (progDesc "Decompress a file"))
    <> command "compress" (info compress (progDesc "Compress a file"))
    <> command "transcode" (info transcode (progDesc "Convert a file's compression"))
    <> command "verify" (info verify (progDesc "Check the integrity of a compressed file"))
    <> command "matrix" (info matrix (progDesc "Compress a file to all available formats"))
    <> command "recompress" (info recompress (progDesc "Recompress a file (for instance, to compress it at a higher level)"))
    <> command "info" (info infoFile (progDesc "Guess file compression"))
    )

versionMod :: Parser (a -> a)
versionMod = infoOption allVersionsString (short 'V' <> long "version" <> help "Show version")

topLevel :: ParserInfo Command
topLevel = info (helper <*> versionMod <*> cmd)
    (fullDesc
    <> progDesc "A Haskell compressor tool"
    <> header "sak - a Swiss-army knife for compression")

main :: IO ()
main = run =<< execParser topLevel