client side is fully working.

import Options.Applicative

import Data.Semigroup ((<>))

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

import Data.Maybe (isJust, fromMaybe)

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

import System.Directory ( createDirectoryIfMissing

                        , doesFileExist

                        , removeDirectoryRecursive

import Control.Concurrent (threadDelay)

import Control.Concurrent.QSem

import Control.Concurrent.Async (async, wait)

import Control.Monad.Trans.Maybe

import Control.Monad.IO.Class (liftIO)

import System.Socket (SocketException)

import qualified Data.Text as T

import qualified Data.ByteString.Lazy as LB

import qualified Data.ByteString.Char8 as Char8

import Network.HTTP.Types (statusCode)

import Network.HTTP.Simple

import Network.HTTP.Client (path)

import Network.HTTP.Client (path, responseStatus)

import Formatting hiding (bytes)

import Control.Retry (retrying, constantDelay, limitRetries, rsIterNumber)

import RD.Lib (sha1sumOnBytes, guessFilename)

import Type

import Opts

debug :: Show a => RDOptions -> a -> IO ()

debug opts msg = when (verbose opts) $ print msg

debug :: RDOptions -> String -> IO ()

debug opts msg = when (verbose opts) $ putStrLn msg

-- | convert byte number to MiB. small number will become 0.

humanReadableSize :: Integer -> String

    , fbpBlockWithChecksum :: BlockWithChecksum

    , fbpBlockTargetFile :: FilePath }

-- | Run an action and recover from a raised exception by potentially retrying

-- the action a number of times. see Control.Retry.recovering for more info.

-- delay is in microseconds.

--

-- this function only capture HttpException in action op.

retryOnFailure :: Int -> Int -> IO Bool -> IO Bool

retryOnFailure times delay op = retrying policy checker wrappedAction where

  policy = constantDelay delay <> limitRetries times

  checker _rs = return . not

  wrappedAction rs = do

    when (rsIterNumber rs > 0)

         (putStrLn $ "retrying for the " <> show (rsIterNumber rs) <> " time")

    op `catches` [Handler (\ (e :: HttpException) -> do

                             print $ "got HttpException: " <> show e

                             return False)

                 ,Handler (\ (e :: IOException) -> do

                             print $ "got IOException: " <> show e

                             return False)

                 ,Handler (\ (e :: SocketException) -> do

                             print $ "got SocketException: " <> show e

                             return False)]

-- | try fetch block data from http, if fetched data matches sha1sum, write it

-- to blockTargetFile and return IO True. Otherwise, return IO False.

fetchBlockFromHttp :: RDOptions -> FetchBlockParam -> IO Bool

      rangeHeader = "bytes=" <> Char8.pack (show start) <> "-"

                             <> Char8.pack (show end)

  assert (sha1sum /= "pending") (return ())

  -- TODO capture http error. implement retry here.

  debug opts $ "downloading " <> filename <> " block " <> show blockId

  req <- parseRequest $ T.unpack $ fbpUrl fbp

  response <- httpLBS $ addRequestHeader "Range" rangeHeader req

  let statuscode = statusCode $ responseStatus response

  if statuscode /= 206 then do

      putStrLn $ "get block " <> show blockId <> " failed, HTTP status code is " <> show statuscode

      return False

  else do

      let bodyLBS = getResponseBody response

      if (decodeUtf8 . LB.toStrict . sha1sumOnBytes) bodyLBS == sha1sum then do

          let blockTargetFile = fbpBlockTargetFile fbp

      blockFileDir = tempDir opts </> filename

      blockFilename = getBlockFilename rdResp blockWithChecksum

      blockTargetFile = blockFileDir </> blockFilename

  result <- catchJust (guard . isPermissionError)

  result <- catchIOError

            (do

              createDirectoryIfMissing True blockFileDir

              return True)

            (\_ -> do

               putStrLn $ "Create temp dir " <> blockFileDir <> " failed. Make sure you have correct permission."

            (\e -> do

               putStrLn $ "Create temp dir " <> blockFileDir <> " failed: " <> show e

               return False)

  if not result then

      return False

    if fileExist then

        return True

    else

        fetchBlockFromHttp opts (FetchBlockParam url filename blockWithChecksum blockTargetFile)

        retryOnFailure (blockMaxRetry opts) 1000000 $ 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

fetchBlockAsync rc url rdResp blockWithChecksum =

  bracket_

    (waitQSem $ workerSem rc)

    (signalQSem $ workerSem rc)

    $ do

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

      result <- wait ar

      return result

      wait ar

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

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

      getBlockTargetFile blockWithChecksum = blockFileDir </> getBlockFilename rdResp blockWithChecksum in

  map getBlockTargetFile (respBlocks rdResp)

-- | combine downloaded blocks to the final file. Return IO True on success.

combineBlocks :: RDOptions -> RDResponse -> IO Bool

combineBlocks opts rdResp = do

-- | return target file base filename and full name.

getTargetFilename :: RDOptions -> RDResponse -> (FilePath, FilePath)

getTargetFilename 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.

      targetFilename = outDir </> filename in

  (filename, targetFilename)

-- | combine downloaded blocks to the final file. let MaybeT finish with Just

-- on success.

combineBlocks :: RDOptions -> RDResponse -> MaybeT IO ()

combineBlocks opts rdResp = do

  let (filename, targetFilename) = getTargetFilename opts rdResp

  fileExist <- liftIO $ doesFileExist targetFilename

  when (forceOverwrite opts && fileExist) $ do

      result <- liftIO $ catchIOError

        (do

          removeFile targetFilename

          return True)

        (\e -> do

           putStrLn $ "remove existing file failed: " <> show e

           return False)

      unless result mzero

  liftIO $ do

    putStrLn $ "combining blocks to create " <> targetFilename

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

      debug opts $ "appending block file " <> blockFilename

      content <- LB.readFile blockFilename

    LB.appendFile targetFilename content

      LB.appendFile targetFilename content  -- TODO how to handle error here?

                                            -- let it crash?

    putStrLn $ "file downloaded to " <> targetFilename

    unless (keepBlockData opts) $ do

      let tempdir = tempDir opts </> filename

      debug opts $ "delete temporary block data dir " <> tempdir

    removeDirectoryRecursive tempdir

  return True

      catchIOError (removeDirectoryRecursive tempdir)

                   (\e -> putStrLn $ "Warning: delete temp block data dir failed: " <> show e)

-- | call /rd/<file> api and fetch response

getRDResponse :: RDOptions -> T.Text -> IO RDResponse

getRDResponse _opts url = do

getRDResponse _opts url = catches

  (do

    req <- parseRequest $ T.unpack url

    resp <- httpJSON $ req { path="/rd" <> path req }

  return $ getResponseBody resp

    return $ getResponseBody resp)

   [Handler (\ (e :: HttpException) -> do

               putStrLn $ "getRDResponse HttpException: " <> show e

               return $ rdErrorResponse {

                            respOk=False

                          , respMsg="got HttpException " <> T.pack (show e)})

   ,Handler (\ (e :: JSONException) -> do

               putStrLn $ "getRDResponse JSONException: " <> show e

               return $ rdErrorResponse {

                            respOk=False

                          , respMsg="json decode failed: " <> T.pack (show e)})]

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

-- downloading.

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

downloadFile :: RDClientRuntimeConfig -> T.Text -> MaybeT 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

  rdResp <- liftIO $ getRDResponse opts url

  unless (respOk rdResp) $ do

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

    mzero

  liftIO $ putStrLn "GET /rd/ api ok"

  let (_filename, targetFilename) = getTargetFilename opts rdResp

  fileExist <- liftIO $ doesFileExist targetFilename

  when (fileExist && not (forceOverwrite opts)) $ do

    liftIO $ putStrLn $ "Warning: skip already existing file " <> targetFilename <> ", use -f to force overwrite"

    mzero

  liftIO $ do

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

             <> humanReadableSize (respFileSize rdResp)

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

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

          if and results then

              combineBlocks opts rdResp2

    if and results then do

      resultMaybe <- runMaybeT $ combineBlocks opts rdResp2

      return $ isJust resultMaybe

    else do

      putStrLn $ (show . length . filter id) results <> " blocks failed."

      return False

      readyBlocks = filter blockIsReady blocks

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

      allBlocksReady = all blockIsReady blocks

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

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

  results <- mapM (fetchBlockAsync rc url rdResp) newReadyBlocks

  if allBlocksReady then

    -- loop finished

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

         threadDelay 1000000

    newRdResp <- getRDResponse (rdOptions rc) url

    unless (respOk newRdResp) $ do

         putStrLn $ "getRDResponse failed: " <> T.unpack (respMsg newRdResp)

    let prevResp = if respOk newRdResp then newRdResp else rdResp

    loopUntilAllBlocksReady rc url prevResp (map getBlockId readyBlocks)

cliApp opts = do

  debug opts $ "command line options: " <> show opts

  let dir = tempDir opts

  catchJust (guard . isPermissionError)

            (createDirectoryIfMissing True dir)

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

  catchIOError (createDirectoryIfMissing True dir)

               (\e -> die $ "Create temp dir " <> dir <> " failed: " <> show e)

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

  sem <- newQSem $ workerCount opts

  let rc = RDClientRuntimeConfig { rdOptions=opts

                                 , workerSem=sem}

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

  -- resultsMaybe :: [Maybe Bool]

  resultsMaybe <- mapM (runMaybeT . downloadFile rc) (urls opts)

  let results = map (fromMaybe False) resultsMaybe

  if and results then

      putStrLn "all urls downloaded."

  else

      die $ (show . length . filter id) results <> " urls failed."

      die $ (show . length . filter not) results <> " urls failed/skipped."

main :: IO ()

main = cliApp =<< execParser opts

      <> showDefault

      <> value 5

      <> metavar "INT" )

  <*> switch

      (  long "verbose"

      <> short 'v'

      <> help "show more debug message"

      <> showDefault )

  <*> switch

      (  long "force"

      <> short 'f'

      <> help "overwrite exiting target file in OUTPUT_DIR"

      <> showDefault )

  <*> switch

      (  long "verbose"

      <> short 'v'

      <> help "show more debug message"

      <> showDefault )

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

* COMMENT -*- mode: org -*-

#+Date: 2018-05-04

Time-stamp: <2018-05-07>

Time-stamp: <2018-05-08>

#+STARTUP: content

* notes                                                               :entry:

** 2018-05-08 example run in prod env

- try it on de03

  on ryzen5,

  cd ~/projects/reliable-download/

  scp .stack-work/install/x86_64-linux-nopie/lts-10.3/8.2.2/bin/rd-api de01:d/

  on de01,

  cd ~/d/

  chmod +x rd-api

  env WEB_ROOT=$PWD ./rd-api

  curl -v http://138.201.95.248:8082/rd/

  curl -I http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

  okay.

  378M gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

  on ryzen5,

  tmake stack exec rd -- -d ~/d/.blocks -o ~/d/ http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

  #+BEGIN_SRC sh

    sylecn@ryzen5:~/projects/reliable-download$ tmake stack exec rd -- -d ~/d/.blocks -o ~/d/ http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    Tue May  8 00:45:31 CST 2018

    will start timed run in 3 sec

    running command: stack exec rd -- -d /home/sylecn/d/.blocks -o /home/sylecn/d/ http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    GET /rd/ api ok

    Downloading file: "gitlab-ce_10.3.5-ce.0_amd64_xenial.deb", 377 MiB, 189 blocks

    189 new block(s) ready on server side

    combining blocks to create /home/sylecn/d/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    file downloaded to /home/sylecn/d/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    all urls downloaded.

    started at 2018-05-08 00:45:34

    stopped at 2018-05-08 00:47:20

    Duration: 106 seconds

    sylecn@ryzen5:~/projects/reliable-download$

  #+END_SRC

  except for lacking progress info and download speed info.

  download works perfectly.

  sha1sum for the whole file matches.

** 2018-05-06 how to run rd-api in dev env

- how to run rd-api

Network.HTTP.Client

https://www.stackage.org/haddock/lts-10.3/http-client-0.5.7.1/Network-HTTP-Client.html

how to handle exceptions in http-client?

http-client/TUTORIAL.md at master · snoyberg/http-client

https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md#exceptions

** 2018-05-06 handle IO exceptions

- Control.Exception

  https://www.stackage.org/haddock/lts-10.3/base-4.10.1.0/Control-Exception.html

* current                                                             :entry:

** 

** 2018-05-08 humanReadableSize: round up when convert byte to MiB. rd shows 377 MiB

or just show as floating point with 1 digit after point.

** 2018-05-08 when start rd-api, make error obvious if connect to redis failed.

Current error is like this:

#+BEGIN_SRC sh

  root@us01:~/d# env WEB_ROOT=$PWD ./rd-api

  2018-05-07 16:32:13 INFO Main: webRoot is /root/d

  rd-api: Network.Socket.connect: <socket: 11>: does not exist (Connection refused)

#+END_SRC

** 2018-05-08 mkApp has shifting to the right problem.

try write in MaybeT

* done                                                                :entry:

** 2018-05-06 write client side tool to actually do the download.

- make this work:

  env WEB_ROOT=/home/sylecn/persist/cache stack exec rd-api

  stack exec rd -- -d ~/d/.blocks -o ~/d/ http://localhost:8082/ideaIC-2018.1.tar.gz

- try it on de03

  on ryzen5,

  cd ~/projects/reliable-download/

  scp .stack-work/install/x86_64-linux-nopie/lts-10.3/8.2.2/bin/rd-api de01:d/

  on de01,

  cd ~/d/

  chmod +x rd-api

  env WEB_ROOT=$PWD ./rd-api

  curl -v http://138.201.95.248:8082/rd/

  curl -I http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

  okay.

  378M gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

  on ryzen5,

  tmake stack exec rd -- -d ~/d/.blocks -o ~/d/ http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

  #+BEGIN_SRC sh

    sylecn@ryzen5:~/projects/reliable-download$ tmake stack exec rd -- -d ~/d/.blocks -o ~/d/ http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    Tue May  8 00:45:31 CST 2018

    will start timed run in 3 sec

    running command: stack exec rd -- -d /home/sylecn/d/.blocks -o /home/sylecn/d/ http://138.201.95.248:8082/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    GET /rd/ api ok

    Downloading file: "gitlab-ce_10.3.5-ce.0_amd64_xenial.deb", 377 MiB, 189 blocks

    189 new block(s) ready on server side

    combining blocks to create /home/sylecn/d/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    file downloaded to /home/sylecn/d/gitlab-ce_10.3.5-ce.0_amd64_xenial.deb

    all urls downloaded.

    started at 2018-05-08 00:45:34

    stopped at 2018-05-08 00:47:20

    Duration: 106 seconds

    sylecn@ryzen5:~/projects/reliable-download$

  #+END_SRC

  except for lacking progress info and download speed info.

  download works perfectly.

  sha1sum for the whole file matches.

- problems

  - rd-api failed to run on us01.

    #+BEGIN_SRC sh

      root@us01:~/d# chmod +x rd-api

      root@us01:~/d# env WEB_ROOT=$PWD ./rd-api

      2018-05-07 16:32:13 INFO Main: webRoot is /root/d

      rd-api: Network.Socket.connect: <socket: 11>: does not exist (Connection refused)

    #+END_SRC

    it's redis. redis not running on us01.

  - try it on us01.

    on ryzen5,

    cd ~/projects/reliable-download/

    scp .stack-work/install/x86_64-linux-nopie/lts-10.3/8.2.2/bin/rd-api us01:d/

    on us01,

    cd ~/d/

    chmod +x rd-api

    env HOST=0.0.0.0 PORT=8082 WEB_ROOT=$PWD ./rd-api

    // us01 is too slow for anything. probably high level of oversell.

** 2018-05-07 add reliability to client code.

- DONE If some block sha1sum is pending, go-to a sleep loop, retry until there

  are no pending blocks. Filter pending blocks when sending download task to

  - MOVED how to track progress?

- retry download if sha1sum verification failed.

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

- DONE retry download if sha1sum verification failed.

  in extra pkg.

  Control.Exception.Extra

  retry :: Int -> IO a -> IO a

  how to retry with a delay? just combine your IO a with a IO ().

  retry pkg.

  Control.Retry

  https://www.stackage.org/haddock/lts-10.3/retry-0.7.5.1/Control-Retry.html

  this looks better. built-in support for delay.

  if there is http error, or result is IO False, retry.

  just capture http error myself and return IO False.

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

  fail at correct checkpoints.

  http IO:

      op `catch` (\ (e :: HttpException) -> do

                    print $ "got HttpException: " <> show e

                    return False)

  disk IO:

  use catchIOError

  learn how to return early elegantly.

  Control.Monad.Trans.Maybe

  https://www.stackage.org/haddock/lts-10.3/transformers-0.5.2.0/Control-Monad-Trans-Maybe.html

  MaybeT monad transformer

  Clean Alternatives with MaybeT

  http://www.parsonsmatt.org/2016/11/18/clean_alternatives_with_maybet.html

  Monad Transformers - School of Haskell | School of Haskell

  https://www.schoolofhaskell.com/user/commercial/content/monad-transformers

  MaybeT is very difficult to understand.

  The examples are not good enough.

  haskell - Simplest non-trivial monad transformer example for "dummies", IO+Maybe - Stack Overflow

  https://stackoverflow.com/questions/32579133/simplest-non-trivial-monad-transformer-example-for-dummies-iomaybe

  see ./t1/Main.hs

  client/Main.hs

  downloadFile no longer shift to the right after switching to MaybeT IO Bool.

- DONE handle non-2xx response.

  https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md#non-2xx-responses-1

  only two places, 

  - getRDResponse GET /rd

    handled in-place

  - fetchBlockFromHttp GET /file with Range header.

    handled in retryOnFailure wrapperAction.

- problems

  - does haskell support TCO?

    https://softwareengineering.stackexchange.com/questions/144274/whats-the-difference-between-recursion-and-corecursion

  - DONE webRoot is /nonexistent?

    fixed.

** 2018-05-06 write client side tool to actually do the download.

- make this work:

  env WEB_ROOT=/home/sylecn/persist/cache stack exec rd-api

** 2018-05-07 retrying has no error msg print on cli?

what's the problem?

  stack exec rd -- -d ~/d/.blocks -o ~/d/ http://localhost:8082/ideaIC-2018.1.tar.gz

- 

- when testing -f option

  stack exec rd -- -f -d ~/d/.blocks -o ~/d/ http://localhost:8082/sdkman.sh

  first call success

  2nd call keep retrying without showing any error message.

- reset client side env and try again.

  rm -rf ~/d/.blocks/sdkman.sh/

  rm -rf ~/d/sdkman.sh

  stack exec rd -- -f -d ~/d/.blocks -o ~/d/ http://localhost:8082/sdkman.sh

  enable verbose mode.

  stack exec rd -- -v -f -d ~/d/.blocks -o ~/d/ http://localhost:8082/sdkman.sh

  #+BEGIN_QUOTE

  An action to check whether the result should be retried. If True, we delay

  and retry the operation.

  #+END_QUOTE

  If True, we delay and retry the operation.

  // should use not.

  fixed.

* done                                                                :entry:

** 2018-05-06 implement rd client basic logic.

- how to handle IO exception?

    - optparse-applicative

    - http-conduit

    - http-client

    - http-types

    - async

    - retry

    - transformers

    - socket

    ghc-options:

    - -threaded

import Data.Monoid ((<>))

import Data.Text.Encoding (decodeUtf8)

import Control.Concurrent.Chan

import System.IO.Error (catchIOError)

import qualified Data.Text as T

import qualified Data.Text.Lazy as LT

    path :: T.Text <- param "1"

    let filepath = webRoot (rcConfig runtimeConfig) </> T.unpack path

    liftIO $ putStrLn $ "user request " <> filepath

    fileStatus <- liftIO $ getFileStatus filepath    -- TODO catch IO exception

    fileStatusE <- liftIO $ catchIOError

      (fmap Right (getFileStatus filepath))

      (\e -> return $ Left $ "getFileStatus failed: " <> show e)

    case fileStatusE of

      Left errMsg -> json $ rdErrorResponse { respMsg=T.pack errMsg }  -- TODO how to do early return here?

      Right fileStatus -> do

        let fileSizeInByte = toInteger $ fileSize fileStatus

            blockSizeInByte = 2097152    -- 2MiB

            blockCount = (fileSizeInByte - 1) `div` blockSizeInByte + 1