implement --worker, --force option.

import Control.Monad (guard, when, unless, forM_)

import System.Directory (createDirectoryIfMissing

                        , doesFileExist

                        , removeDirectoryRecursive)

                        , removeDirectoryRecursive

                        , removeFile)

import Control.Exception

import System.IO.Error

import System.Exit

import System.FilePath ((</>))

import Data.Text.Encoding (decodeUtf8)

import Control.Concurrent (threadDelay)

import Control.Concurrent.QSem

import Control.Concurrent.Async (async, wait)

import qualified Data.Text as T

import qualified Data.ByteString.Lazy as LB

import qualified Data.ByteString.Char8 as Char8

    else

        fetchBlockFromHttp opts (FetchBlockParam url filename blockWithChecksum blockTargetFile)

-- | fetch block asynchronously using a worker pool

fetchBlockAsync :: RDClientRuntimeConfig -> T.Text -> RDResponse -> BlockWithChecksum -> IO Bool

fetchBlockAsync rc url rdResp blockWithChecksum = do

  bracket_

    (waitQSem $ workerSem rc)

    (signalQSem $ workerSem rc)

    $ do

      ar <- async $ fetchBlock (rdOptions rc) url rdResp blockWithChecksum

      result <- wait ar

      return result

-- | return block target file names in correct order.

getBlockTargetFilenames :: RDOptions -> RDResponse -> [FilePath]

getBlockTargetFilenames opts rdResp =

  let outDir = outputDir opts

      filename = guessFilename $ respPath rdResp

      targetFilename = outDir </> filename

  fileExist <- doesFileExist targetFilename

  when (forceOverwrite opts && fileExist) $

    removeFile targetFilename  -- TODO if remove failed, return IO False early.

  putStrLn $ "combining blocks to create " <> targetFilename

  forM_ (getBlockTargetFilenames opts rdResp) $ \blockFilename -> do

    debug opts $ "appending block file " <> blockFilename

-- | download file at given URL using reliable download API and block based

-- downloading.

downloadFile :: RDOptions -> T.Text -> IO Bool

downloadFile opts url = do

downloadFile :: RDClientRuntimeConfig -> T.Text -> IO Bool

downloadFile rc url = do

  let opts = rdOptions rc

  rdResp <- getRDResponse opts url

  if not $ respOk rdResp then do

      putStrLn $ "GET /rd/ api failed: " <> show (respMsg rdResp)

      return False

  else do

      putStrLn "GET /rd/ api ok"

      let outDir = outputDir opts

          filename = guessFilename $ respPath rdResp

          targetFilename = outDir </> filename

      fileExist <- doesFileExist targetFilename

      if fileExist && not (forceOverwrite opts) then do

          putStrLn $ "Warning: skip already existing file " <> targetFilename

          return False    -- how to return early?

      else do

          putStrLn $ "Downloading file: " <> show (respPath rdResp) <> ", "

                   <> humanReadableSize (respFileSize rdResp)

                   <> ", " <> show (respBlockCount rdResp) <> " blocks"

      (rdResp2, results) <- loopUntilAllBlocksReady opts url rdResp []

          (rdResp2, results) <- loopUntilAllBlocksReady rc url rdResp []

          if and results then

              combineBlocks opts rdResp2

          else do

-- blocks are sent to fetchBlock function.

--

-- Return whether download is successful for each block.

loopUntilAllBlocksReady :: RDOptions -> T.Text -> RDResponse -> [BlockID] -> IO (RDResponse, [Bool])

loopUntilAllBlocksReady opts url rdResp oldReadyBlocks = do

loopUntilAllBlocksReady :: RDClientRuntimeConfig -> T.Text -> RDResponse -> [BlockID] -> IO (RDResponse, [Bool])

loopUntilAllBlocksReady rc url rdResp oldReadyBlocks = do

  let blockIsReady = (/= "pending") . getBlockSha1sum

      blocks = respBlocks rdResp

      readyBlocks = filter blockIsReady blocks

      newReadyBlocks = filter ((`notElem` oldReadyBlocks) . getBlockId) readyBlocks

      allBlocksReady = all blockIsReady blocks

  putStrLn $ (show . length) newReadyBlocks <> " new blocks ready on server side"

  results <- mapM (fetchBlock opts url rdResp) newReadyBlocks

  results <- mapM (fetchBlockAsync rc url rdResp) newReadyBlocks

  if allBlocksReady then

    -- loop finished

    return (rdResp, results)

    when (null newReadyBlocks) $ do

         putStrLn "No new blocks ready on server side, waiting 1s"

         threadDelay 1000000

    newRdResp <- getRDResponse opts url

    newRdResp <- getRDResponse (rdOptions rc) url

    let prevResp = if respOk newRdResp then newRdResp else rdResp

    loopUntilAllBlocksReady opts url prevResp (map getBlockId readyBlocks)

    loopUntilAllBlocksReady rc url prevResp (map getBlockId readyBlocks)

cliApp :: RDOptions -> IO ()

cliApp opts = do

            (createDirectoryIfMissing True dir)

            (\_ -> die $ "Create temp dir " <> dir <> " failed. Make sure you have correct permission.")

  debug opts $ "using temp dir: " <> dir

  results <- mapM (downloadFile opts) (urls opts)

  sem <- newQSem $ workerCount opts

  let rc = RDClientRuntimeConfig { rdOptions=opts

                                 , workerSem=sem}

  results <- mapM (downloadFile rc) (urls opts)

  if and results then

      putStrLn "all urls downloaded."

  else

module Opts (RDOptions(..), argParser) where

module Opts (RDOptions(..), argParser, RDClientRuntimeConfig(..)) where

import qualified Data.Text as T

import Data.Semigroup ((<>))

import Control.Concurrent.QSem

import Options.Applicative

  , tempDir :: FilePath

  , outputDir :: FilePath

  , workerCount :: Int

  , forceOverwrite :: Bool

  , verbose :: Bool

  , urls :: [T.Text] } deriving (Show)

data RDClientRuntimeConfig = RDClientRuntimeConfig

    { rdOptions :: RDOptions

    , workerSem :: QSem }

argParser :: Parser RDOptions

argParser = RDOptions

  <$> option auto

      <> short 'v'

      <> help "show more debug message"

      <> showDefault )

  <*> switch

      (  long "force"

      <> short 'f'

      <> help "overwrite exiting target file in OUTPUT_DIR"

      <> showDefault )

  <*> some (argument str (metavar "URL..."))

** 2018-05-06 optparse-applicative :: Stackage Server

https://www.stackage.org/lts-10.3/package/optparse-applicative-0.14.0.0

* later                                                               :entry:

** 2018-05-07 loopUntilAllBlocksReady, how to track progress?

use a thread pool to download blocks, print overall progress when some parts

done or some time elapsed.

- how to track progress?

  I used mapM to fetch block.

  results <- mapM (fetchBlockAsync opts rc url rdResp) newReadyBlocks

  how to show some progress info?

  I need a supervisor thread. and I need a shared data structure.

  a mapM is not enough to do this.

- 

** 2018-05-05 add logging support

- hslogger

  http://hackage.haskell.org/package/hslogger-1.2.10/docs/System-Log-Logger.html

  should I use Control.Monad.Trans.Loop or just recursive call?

  I used recursive call.

- use a thread pool to download blocks. print overall progress when some

- DONE use a thread pool to download blocks. print overall progress when some

  parts done or some time elapsed.

  thread pool

  async

  async-extra

  mapConcurrentlyBounded

  this is list local though. not a global pool.

  maybe it's good enough for me?

  what if one block keeps failing? it may block the new ready blocks.

  It's easy to implement.

  use a semaphore. when trying to fetch block, accquire a resource, fork a

  thread and run it, wait for result. return the resource. Can use async to

  implement the fork, it is said to handle exceptions better.

  using QSem, I don't have a worker pool. I just create one when I need to do

  some work. If a pool is necessary, need to create it before hand. like the

  rd-api worker.

  - MOVED how to track progress?

- retry download if sha1sum verification failed.

- catch all IO exceptions, including disk io, redis io, http io.

  fail at correct checkpoints.

    main:             Main.hs

    dependencies:

    - reliable-download

    ghc-options:

    - -threaded

  rd:

    source-dirs:      client

    main:             Main.hs

    - optparse-applicative

    - http-conduit

    - http-client

    - async

    ghc-options:

    - -threaded

tests:

  all-tests: