Skip to content
Commits on Source (9)
Expand all Hide whitespace changes
Inline Side-by-side
.gitignore
View file @ 4836bda5
...@@ -8,3 +8,4 @@ pypi/rd-api/rdapi/rd-api ...@@ -8,3 +8,4 @@ pypi/rd-api/rdapi/rd-api
*README.rst *README.rst
stack.yaml.lock stack.yaml.lock
*.whl *.whl
README.md
View file @ 4836bda5
...@@ -48,7 +48,7 @@ Usage: rd-api [-h|--host HOST] [-p|--port PORT] [--redis-host REDIS_HOST] ...@@ -48,7 +48,7 @@ Usage: rd-api [-h|--host HOST] [-p|--port PORT] [--redis-host REDIS_HOST]
$ ls $ ls
bigfile1 bigfile2 bigfile1 bigfile2
$ rd-api --host 0.0.0.0 --port 8082 $ rd-api --host 0.0.0.0 --port 8082
client side: client side:
$ rd http://server-ip:8082/bigfile1 $ rd http://server-ip:8082/bigfile1
......
lib/RD/CliVersion.hs
View file @ 4836bda5
module RD.CliVersion (cliVersion) where module RD.CliVersion (cliVersion) where
cliVersion :: String cliVersion :: String
cliVersion = "1.4.0.0" cliVersion = "1.5.0.0"
lib/RD/Utils.hs
View file @ 4836bda5
-- | Utils contains general functions that is useful for all haskell projects. -- | Utils contains general functions that is useful for all haskell projects.
module RD.Utils where module RD.Utils ( showt
, throwOnLeft
, throwOnLeftMsg
, encodeUtf8
, decodeUtf8
) where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Control.Error import Control.Error
......
operational
View file @ 4836bda5
This diff is collapsed.
package.yaml
View file @ 4836bda5
name: reliable-download name: reliable-download
version: 1.2.0.0 version: 1.2.5.0
synopsis: provide reliable download service via HTTP synopsis: provide reliable download service via HTTP
description: reliable-download web application and cli tool description: reliable-download web application and cli tool
homepage: "https://gitlab.emacsos.com/sylecn/reliable-download" homepage: "https://gitlab.emacsos.com/sylecn/reliable-download"
...@@ -7,7 +7,7 @@ bug-reports: "https://gitlab.emacsos.com/sylecn/reliable-download/issues ...@@ -7,7 +7,7 @@ bug-reports: "https://gitlab.emacsos.com/sylecn/reliable-download/issues
license: GPL-3 license: GPL-3
author: Yuanle Song author: Yuanle Song
maintainer: sylecn@gmail.com maintainer: sylecn@gmail.com
copyright: "Copyright: (c) 2018, 2019, 2022 Yuanle Song" copyright: "Copyright: (c) 2018, 2019, 2022, 2024 Yuanle Song"
category: Utilities category: Utilities
extra-source-files: extra-source-files:
- README.md - README.md
...@@ -25,6 +25,7 @@ default-extensions: ...@@ -25,6 +25,7 @@ default-extensions:
dependencies: dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
# project specific # project specific
- http-types
- scotty - scotty
- wai - wai
- warp - warp
...@@ -41,6 +42,7 @@ dependencies: ...@@ -41,6 +42,7 @@ dependencies:
# data types # data types
- bytestring - bytestring
- text - text
- utf8-string
- unordered-containers - unordered-containers
- aeson - aeson
- extra - extra
...@@ -71,7 +73,6 @@ executables: ...@@ -71,7 +73,6 @@ executables:
- io-thread-pool - io-thread-pool
- http-conduit - http-conduit
- http-client - http-client
- http-types
- retry - retry
- socket - socket
ghc-options: ghc-options:
...@@ -99,6 +100,7 @@ tests: ...@@ -99,6 +100,7 @@ tests:
- hspec - hspec
- hspec-wai - hspec-wai
- http-types - http-types
- http-client
- wai-extra - wai-extra
- unordered-containers - unordered-containers
- binary - binary
pypi/rd-api/README.rst
View file @ 4836bda5
...@@ -31,8 +31,8 @@ To install this package: ...@@ -31,8 +31,8 @@ To install this package:
.. code-block:: bash .. code-block:: bash
$ sudo apt install -y redis-server # redis is used to cache block sha1sum $ sudo apt install -y redis-server pipx # redis is used to cache block sha1sum
$ pip install --user rd-api $ pipx install rd-api
$ rd-api --help $ rd-api --help
$ ~/.local/bin/rd-api --help # if ~/.local/bin/ is not in PATH $ ~/.local/bin/rd-api --help # if ~/.local/bin/ is not in PATH
...@@ -82,6 +82,10 @@ https://gitlab.emacsos.com/sylecn/reliable-download ...@@ -82,6 +82,10 @@ https://gitlab.emacsos.com/sylecn/reliable-download
ChangeLog ChangeLog
--------- ---------
* v1.5.0.0 2024-04-08
- bugfix: properly handle unicode string in URL path
- bugfix: use local time in log messages instead of UTC time
* v1.4.0.0 2023-10-18 * v1.4.0.0 2023-10-18
- feature: rd-api listen host defaults to ::, so it works on both ipv4 and ipv6. - feature: rd-api listen host defaults to ::, so it works on both ipv4 and ipv6.
......
pypi/rd-client/README.rst
View file @ 4836bda5
...@@ -57,6 +57,11 @@ https://gitlab.emacsos.com/sylecn/reliable-download ...@@ -57,6 +57,11 @@ https://gitlab.emacsos.com/sylecn/reliable-download
ChangeLog ChangeLog
--------- ---------
* v1.5.0.0 2024-04-08
- bugfix: properly handle unicode string in URL path
- bugfix: use local time in log messages instead of UTC time
- bugfix: rd client now supports ipv6 address in URL
* v1.3.0.0 2022-03-15 * v1.3.0.0 2022-03-15
- feature: add download progress logging - feature: add download progress logging
......
rd-api/RD/Server/App.hs
View file @ 4836bda5
...@@ -4,14 +4,12 @@ import Control.Monad.IO.Class (liftIO) ...@@ -4,14 +4,12 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Either.Extra (fromRight') import Data.Either.Extra (fromRight')
import Data.Text.Encoding (decodeUtf8)
import Control.Concurrent.Chan import Control.Concurrent.Chan
import System.IO.Error (catchIOError) import System.IO.Error (catchIOError)
import Control.Monad (unless) import Control.Monad (unless)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Network.Wai (Application) import Network.Wai (Application, pathInfo)
import Web.Scotty import Web.Scotty
import Data.Aeson (object, (.=)) import Data.Aeson (object, (.=))
import System.FilePath ((</>)) import System.FilePath ((</>))
...@@ -34,11 +32,11 @@ fillSha1sum rc fbp = do ...@@ -34,11 +32,11 @@ fillSha1sum rc fbp = do
redisReply <- R.runRedis (rcRedisConn rc) $ R.hgetall hashKey redisReply <- R.runRedis (rcRedisConn rc) $ R.hgetall hashKey
case redisReply of case redisReply of
Left reply -> do Left reply -> do
errorl rc $ "redis hgetall " <> showt hashKey <> " failed: " <> showt reply errorl rc $ "redis hgetall " <> decodeUtf8 hashKey <> " failed: " <> showt reply
return $ map fillBlock (fbpBlocks fbp) where return $ map fillBlock (fbpBlocks fbp) where
fillBlock (blockId, start, end) = (blockId, start, end, "pending") fillBlock (blockId, start, end) = (blockId, start, end, "pending")
Right blockIdSha1sumAlist -> do Right blockIdSha1sumAlist -> do
debugl rc $ "fillSha1sum: redis hgetall " <> showt hashKey <> " ok" debugl rc $ "fillSha1sum: redis hgetall " <> decodeUtf8 hashKey <> " ok"
return $ map fillBlock (fbpBlocks fbp) where return $ map fillBlock (fbpBlocks fbp) where
blockIdSha1sumMap = M.fromList blockIdSha1sumAlist blockIdSha1sumMap = M.fromList blockIdSha1sumAlist
fillBlock :: Block -> BlockWithChecksum fillBlock :: Block -> BlockWithChecksum
...@@ -54,12 +52,12 @@ processNewFileAsyncMaybe rc fbp = do ...@@ -54,12 +52,12 @@ processNewFileAsyncMaybe rc fbp = do
throwOnLeft resultE throwOnLeft resultE
let insertOk = fromRight' resultE let insertOk = fromRight' resultE
if insertOk then liftIO $ do if insertOk then liftIO $ do
infol rc $ showt filePath <> " is a new file, sending task to worker" infol rc $ T.pack filePath <> " is a new file, sending task to worker"
writeChan (rcFileChan rc) fbp writeChan (rcFileChan rc) fbp
return () return ()
else do else do
oldStatusE <- liftIO $ do oldStatusE <- liftIO $ do
debugl rc $ showt filePath <> " is not a new file" debugl rc $ T.pack filePath <> " is not a new file"
-- if status is error, set it to working, then add task to fileChan -- if status is error, set it to working, then add task to fileChan
DB.get rc strKey DB.get rc strKey
throwOnLeftMsg oldStatusE "get old file status failed" throwOnLeftMsg oldStatusE "get old file status failed"
...@@ -79,12 +77,12 @@ processNewFileAsyncMaybe rc fbp = do ...@@ -79,12 +77,12 @@ processNewFileAsyncMaybe rc fbp = do
getRdHandler :: RDRuntimeConfig -> ExceptT T.Text ActionM () getRdHandler :: RDRuntimeConfig -> ExceptT T.Text ActionM ()
getRdHandler rc = do getRdHandler rc = do
unless (rcHasRedis rc) $ unless (rcHasRedis rc) $
throwE "No redis connection, GET /rd/ disabled" throwE "No redis on server side, rd client support is disabled"
path <- lift $ param "1" req <- lift request
let reqFilePath = T.intercalate "/" $ drop 1 $ pathInfo req
let filepath = webRoot (rcConfig rc) </> T.unpack path let filepath = webRoot (rcConfig rc) </> T.unpack reqFilePath
fileStatusE <- lift $ do fileStatusE <- lift $ do
liftIO $ infol rc $ "user request rd metadata for " <> showt filepath liftIO $ infol rc $ "user request rd metadata for " <> T.pack filepath
liftIO $ catchIOError liftIO $ catchIOError
(fmap Right (getFileStatus filepath)) (fmap Right (getFileStatus filepath))
(\e -> do (\e -> do
...@@ -107,14 +105,14 @@ getRdHandler rc = do ...@@ -107,14 +105,14 @@ getRdHandler rc = do
case resultE of case resultE of
Left msg -> json $ Left msg -> json $
object ["ok" .= False object ["ok" .= False
,"path" .= path ,"path" .= reqFilePath
,"filepath" .= filepath ,"filepath" .= filepath
,"msg" .= msg] ,"msg" .= msg]
Right _ -> do Right _ -> do
blocksWithSha1sum <- liftIO $ fillSha1sum rc fbp blocksWithSha1sum <- liftIO $ fillSha1sum rc fbp
json RDResponse { respOk=True json RDResponse { respOk=True
, respMsg="" , respMsg=""
, respPath=path , respPath=reqFilePath
, respFilePath=filepath , respFilePath=filepath
, respBlockSize="2MiB" , respBlockSize="2MiB"
, respFileSize=fileSizeInByte , respFileSize=fileSizeInByte
...@@ -129,18 +127,19 @@ mkApp rc = do ...@@ -129,18 +127,19 @@ mkApp rc = do
,"app" .= ("reliable-download api" :: T.Text) ,"app" .= ("reliable-download api" :: T.Text)
,"version" .= T.pack cliVersion] ,"version" .= T.pack cliVersion]
get (regex "^/rd/(.*)") $ do get (regex "^/rd/") $ do
result <- runExceptT $ getRdHandler rc result <- runExceptT $ getRdHandler rc
case result of case result of
Left msg -> json rdErrorResponse { respMsg=msg } Left msg -> json rdErrorResponse { respMsg=msg }
Right resp -> return resp Right resp -> return resp
get (regex "^/test/rd/(.*)") $ do -- for testing path capture get (regex "^/test-rd/") $ do -- for testing path capture
fullPath :: LT.Text <- param "0" req <- request
path :: LT.Text <- param "1" let fullPath = "/" <> T.intercalate "/" (pathInfo req)
let filepath = webRoot (rcConfig rc) </> LT.unpack path reqFilePath = T.intercalate "/" $ drop 1 $ pathInfo req
let filepath = webRoot (rcConfig rc) </> T.unpack reqFilePath
json $ object ["ok" .= True json $ object ["ok" .= True
,"path" .= path ,"path" .= reqFilePath
,"filepath" .= filepath ,"filepath" .= filepath
,"fullPath" .= fullPath] ,"fullPath" .= fullPath]
......
rd-api/RD/Server/Config.hs
View file @ 4836bda5
...@@ -10,6 +10,7 @@ import Control.Monad.IO.Class ...@@ -10,6 +10,7 @@ import Control.Monad.IO.Class
import qualified System.Logger as L import qualified System.Logger as L
import RD.Types import RD.Types
import RD.Utils
-- | rd-api configuration, supports cli arguments or env variable. -- | rd-api configuration, supports cli arguments or env variable.
data RDConfig = RDConfig { data RDConfig = RDConfig {
...@@ -70,7 +71,7 @@ defaultRDRuntimeConfig config = do ...@@ -70,7 +71,7 @@ defaultRDRuntimeConfig config = do
conn <- R.connect R.defaultConnectInfo conn <- R.connect R.defaultConnectInfo
fileChan <- newChan fileChan <- newChan
let logLevel = if verbose config then L.Debug else L.Info let logLevel = if verbose config then L.Debug else L.Info
logSettings = (L.setFormat (Just "%Y-%0m-%0dT%0H:%0M:%0S") . logSettings = (L.setFormat (Just L.iso8601) .
L.setLogLevel logLevel . L.setLogLevel logLevel .
L.setDelimiter " ") L.defSettings L.setDelimiter " ") L.defSettings
logger <- L.new logSettings logger <- L.new logSettings
...@@ -83,7 +84,7 @@ defaultRDRuntimeConfig config = do ...@@ -83,7 +84,7 @@ defaultRDRuntimeConfig config = do
-- | the redis hash key used to store cached sha1sum for given FillBlockParam -- | the redis hash key used to store cached sha1sum for given FillBlockParam
blockSha1sumHashKey :: FillBlockParam -> B.ByteString blockSha1sumHashKey :: FillBlockParam -> B.ByteString
blockSha1sumHashKey fbp = Char8.pack (fbpFilepath fbp) <> "_" <> (Char8.pack . show) (fbpBlockSize fbp) blockSha1sumHashKey fbp = encodeUtf8 $ T.pack (fbpFilepath fbp) <> "_" <> showt (fbpBlockSize fbp)
-- | the redis hash key sub key, used to store the sha1sum for that blockId. -- | the redis hash key sub key, used to store the sha1sum for that blockId.
blockIdKey :: BlockID -> B.ByteString blockIdKey :: BlockID -> B.ByteString
......
rd-api/RD/Server/DB.hs
View file @ 4836bda5
...@@ -13,7 +13,7 @@ insertIfNotExist rc key value = do ...@@ -13,7 +13,7 @@ insertIfNotExist rc key value = do
redisReply <- R.runRedis (rcRedisConn rc) $ R.setnx key value redisReply <- R.runRedis (rcRedisConn rc) $ R.setnx key value
case redisReply of case redisReply of
Left reply -> do Left reply -> do
errorl rc $ "redis setnx " <> showt key <> " failed:\n\t" <> showt reply errorl rc $ "redis setnx " <> decodeUtf8 key <> " failed:\n\t" <> showt reply
return $ Left "insertIfNotExist on DB failed" return $ Left "insertIfNotExist on DB failed"
Right v -> return $ Right v Right v -> return $ Right v
...@@ -22,7 +22,7 @@ get rc key = do ...@@ -22,7 +22,7 @@ get rc key = do
redisReply <- R.runRedis (rcRedisConn rc) $ R.get key redisReply <- R.runRedis (rcRedisConn rc) $ R.get key
case redisReply of case redisReply of
Left reply -> do Left reply -> do
let msg = "redis get " <> showt key <> " failed: " <> showt reply let msg = "redis get " <> decodeUtf8 key <> " failed: " <> showt reply
errorl rc msg errorl rc msg
return $ Left msg return $ Left msg
Right v -> return $ Right v Right v -> return $ Right v
...@@ -32,7 +32,7 @@ set rc key value = do ...@@ -32,7 +32,7 @@ set rc key value = do
redisReply <- R.runRedis (rcRedisConn rc) $ R.set key value redisReply <- R.runRedis (rcRedisConn rc) $ R.set key value
case redisReply of case redisReply of
Left reply -> do Left reply -> do
let msg = "redis set " <> showt key <> " to " <> showt value <> " failed: " <> showt reply let msg = "redis set " <> decodeUtf8 key <> " to " <> decodeUtf8 value <> " failed: " <> showt reply
errorl rc msg errorl rc msg
return $ Left msg return $ Left msg
Right v -> return $ Right v Right v -> return $ Right v
rd-api/RD/Server/Worker.hs
View file @ 4836bda5
...@@ -45,7 +45,7 @@ fileWorker rc = forever $ do ...@@ -45,7 +45,7 @@ fileWorker rc = forever $ do
let filepath = fbpFilepath fbp let filepath = fbpFilepath fbp
conn = rcRedisConn rc conn = rcRedisConn rc
-- calculate sha1sum for each block and write result to redis hash -- calculate sha1sum for each block and write result to redis hash
infol rc $ "fileWorker working on " <> showt filepath infol rc $ "fileWorker working on " <> T.pack filepath
results <- withBinaryFile filepath ReadMode $ \handle -> do results <- withBinaryFile filepath ReadMode $ \handle -> do
let hashKey = blockSha1sumHashKey fbp let hashKey = blockSha1sumHashKey fbp
mapM (calculateSha1ForBlock conn hashKey handle) (fbpBlocks fbp) mapM (calculateSha1ForBlock conn hashKey handle) (fbpBlocks fbp)
...@@ -55,10 +55,10 @@ fileWorker rc = forever $ do ...@@ -55,10 +55,10 @@ fileWorker rc = forever $ do
Left reply -> Left reply ->
errorl rc $ "Set file status failed: " <> showt reply errorl rc $ "Set file status failed: " <> showt reply
Right _ -> do Right _ -> do
debugl rc $ "Set file status to " <> showt resultStatus <> " for " <> showt filepath debugl rc $ "Set file status to " <> showt resultStatus <> " for " <> T.pack filepath
infol rc $ sformat infol rc $ sformat
("fileWorker done for " % string % ", " % stext % ", " % int % " blocks") ("fileWorker done for " % stext % ", " % stext % ", " % int % " blocks")
filepath (humanReadableSize (fbpFileSize fbp)) (length (fbpBlocks fbp)) (T.pack filepath) (humanReadableSize (fbpFileSize fbp)) (length (fbpBlocks fbp))
return () return ()
where where
-- | calculate sha1 for a single block. return IO True on success. -- | calculate sha1 for a single block. return IO True on success.
...@@ -67,7 +67,7 @@ fileWorker rc = forever $ do ...@@ -67,7 +67,7 @@ fileWorker rc = forever $ do
redisReply <- R.runRedis conn $ R.hget hashKey (blockIdKey blockId) redisReply <- R.runRedis conn $ R.hget hashKey (blockIdKey blockId)
case redisReply of case redisReply of
Left reply -> do Left reply -> do
errorl rc $ "redis hget failed on " <> showt hashKey <> ": " <> showt reply errorl rc $ "redis hget failed on " <> decodeUtf8 hashKey <> ": " <> showt reply
return False return False
Right sha1sumMaybe -> Right sha1sumMaybe ->
case sha1sumMaybe of case sha1sumMaybe of
...@@ -80,12 +80,12 @@ fileWorker rc = forever $ do ...@@ -80,12 +80,12 @@ fileWorker rc = forever $ do
redisReply2 <- R.runRedis conn $ R.hset hashKey (blockIdKey blockId) blockSha1 redisReply2 <- R.runRedis conn $ R.hset hashKey (blockIdKey blockId) blockSha1
case redisReply2 of case redisReply2 of
Left reply -> do Left reply -> do
errorl rc $ "redis hset failed on " <> showt hashKey <> ": " <> showt reply errorl rc $ "redis hset failed on " <> decodeUtf8 hashKey <> ": " <> showt reply
return False return False
Right n -> Right n ->
if n > 0 then if n > 0 then
do do
debugl rc $ "redis hset " <> showt hashKey <> " " <> showt blockId <> " ok" debugl rc $ "redis hset " <> decodeUtf8 hashKey <> " " <> showt blockId <> " ok"
return True return True
else else
return False return False
......
rd/RD/Client/Main.hs
View file @ 4836bda5
...@@ -11,7 +11,6 @@ import Control.Exception ...@@ -11,7 +11,6 @@ import Control.Exception
import System.IO.Error import System.IO.Error
import System.Exit import System.Exit
import System.FilePath ((</>)) import System.FilePath ((</>))
import Data.Text.Encoding (decodeUtf8)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (threadDelay, forkIO) import Control.Concurrent (threadDelay, forkIO)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
...@@ -80,7 +79,7 @@ fetchBlockFromHttp rc fbp = do ...@@ -80,7 +79,7 @@ fetchBlockFromHttp rc fbp = do
rangeHeader = "bytes=" <> Char8.pack (show start) <> "-" rangeHeader = "bytes=" <> Char8.pack (show start) <> "-"
<> Char8.pack (show end) <> Char8.pack (show end)
assert (sha1sum /= "pending") (return ()) assert (sha1sum /= "pending") (return ())
debugl rc $ "downloading " <> showt filename <> " block " <> showt blockId debugl rc $ "downloading " <> T.pack filename <> " block " <> showt blockId
req <- parseRequest $ T.unpack $ fbpUrl fbp req <- parseRequest $ T.unpack $ fbpUrl fbp
response <- httpLBS $ addRequestHeader "Range" rangeHeader req response <- httpLBS $ addRequestHeader "Range" rangeHeader req
let statuscode = statusCode $ responseStatus response let statuscode = statusCode $ responseStatus response
...@@ -92,12 +91,12 @@ fetchBlockFromHttp rc fbp = do ...@@ -92,12 +91,12 @@ fetchBlockFromHttp rc fbp = do
let bodyLBS = getResponseBody response let bodyLBS = getResponseBody response
if (decodeUtf8 . LB.toStrict . sha1sumOnBytes) bodyLBS == sha1sum then do if (decodeUtf8 . LB.toStrict . sha1sumOnBytes) bodyLBS == sha1sum then do
let blockTargetFile = fbpBlockTargetFile fbp let blockTargetFile = fbpBlockTargetFile fbp
debugl rc $ "writing block data to " <> showt blockTargetFile debugl rc $ "writing block data to " <> T.pack blockTargetFile
LB.writeFile blockTargetFile bodyLBS LB.writeFile blockTargetFile bodyLBS
debugl rc $ "block " <> showt blockId <> " fetched" debugl rc $ "block " <> showt blockId <> " fetched"
return True return True
else do else do
errorl rc $ "sha1sum verification failed for " <> showt filename <> " block " <> showt blockId <> ", expect " <> showt sha1sum errorl rc $ "sha1sum verification failed for " <> T.pack filename <> " block " <> showt blockId <> ", expect " <> showt sha1sum
return False return False
-- | return block target file name (just base filename, no dir info) -- | return block target file name (just base filename, no dir info)
...@@ -120,7 +119,7 @@ fetchBlock rc url rdResp blockWithChecksum = do ...@@ -120,7 +119,7 @@ fetchBlock rc url rdResp blockWithChecksum = do
createDirectoryIfMissing True blockFileDir createDirectoryIfMissing True blockFileDir
return True) return True)
(\e -> do (\e -> do
errorl rc $ "Create temp dir " <> showt blockFileDir <> " failed: " <> showt e errorl rc $ "Create temp dir " <> T.pack blockFileDir <> " failed: " <> showt e
return False) return False)
if not result then if not result then
return False return False
...@@ -163,22 +162,22 @@ combineBlocks rc rdResp = do ...@@ -163,22 +162,22 @@ combineBlocks rc rdResp = do
return False) return False)
unless result mzero unless result mzero
liftIO $ do liftIO $ do
infol rc $ "Combining blocks to create " <> showt targetFilename infol rc $ "Combining blocks to create " <> T.pack targetFilename
forM_ (getBlockTargetFilenames opts rdResp) $ \blockFilename -> do forM_ (getBlockTargetFilenames opts rdResp) $ \blockFilename -> do
debugl rc $ "appending block file " <> showt blockFilename debugl rc $ "appending block file " <> T.pack blockFilename
content <- LB.readFile blockFilename content <- LB.readFile blockFilename
LB.appendFile targetFilename content -- how to handle error here? LB.appendFile targetFilename content -- how to handle error here?
-- let it crash. -- let it crash.
when (rollingCombine (rdOptions rc)) $ do when (rollingCombine (rdOptions rc)) $ do
debugl rc $ "delete block file " <> showt blockFilename debugl rc $ "delete block file " <> T.pack blockFilename
catchIOError (removeFile blockFilename) catchIOError (removeFile blockFilename)
(\e -> do (\e -> do
errorl rc $ "Remove block file " <> errorl rc $ "Remove block file " <>
T.pack blockFilename <> " failed: " <> showt e) T.pack blockFilename <> " failed: " <> showt e)
infol rc $ "File downloaded to " <> showt targetFilename infol rc $ "File downloaded to " <> T.pack targetFilename
unless (keepBlockData opts) $ do unless (keepBlockData opts) $ do
let tempdir = tempDir opts </> filename let tempdir = tempDir opts </> filename
debugl rc $ "Delete temporary block data dir " <> showt tempdir debugl rc $ "Delete temporary block data dir " <> T.pack tempdir
catchIOError (removeDirectoryRecursive tempdir) catchIOError (removeDirectoryRecursive tempdir)
(\e -> warnl rc $ "Warning: delete temp block data dir failed: " <> showt e) (\e -> warnl rc $ "Warning: delete temp block data dir failed: " <> showt e)
...@@ -187,6 +186,7 @@ getRDResponse :: RDClientRuntimeConfig -> T.Text -> IO RDResponse ...@@ -187,6 +186,7 @@ getRDResponse :: RDClientRuntimeConfig -> T.Text -> IO RDResponse
getRDResponse rc url = catches getRDResponse rc url = catches
(do (do
req <- parseRequest $ T.unpack url req <- parseRequest $ T.unpack url
debugl rc $ "GET /rd" <> decodeUtf8 (path req)
resp <- httpJSON $ req { path="/rd" <> path req } resp <- httpJSON $ req { path="/rd" <> path req }
return $ getResponseBody resp) return $ getResponseBody resp)
[Handler (\ (e :: HttpException) -> do [Handler (\ (e :: HttpException) -> do
...@@ -208,13 +208,13 @@ downloadFile rc url = do ...@@ -208,13 +208,13 @@ downloadFile rc url = do
downloadTask <- liftIO $ newTask $ workerCount opts downloadTask <- liftIO $ newTask $ workerCount opts
rdResp <- liftIO $ getRDResponse rc url rdResp <- liftIO $ getRDResponse rc url
unless (respOk rdResp) $ do unless (respOk rdResp) $ do
liftIO $ errorl rc $ "GET /rd/ api failed: " <> showt (respMsg rdResp) liftIO $ errorl rc $ "GET /rd/ api failed: " <> respMsg rdResp
mzero mzero
let (baseFilename, targetFilename) = getTargetFilename opts rdResp let (baseFilename, targetFilename) = getTargetFilename opts rdResp
liftIO $ infol rc $ "GET /rd/ api ok for " <> showt baseFilename liftIO $ infol rc $ "GET /rd/ api ok for " <> T.pack baseFilename
fileExist <- liftIO $ doesFileExist targetFilename fileExist <- liftIO $ doesFileExist targetFilename
when (fileExist && not (forceOverwrite opts)) $ do when (fileExist && not (forceOverwrite opts)) $ do
liftIO $ warnl rc $ "Warning: skip already existing file " <> showt targetFilename <> ", use -f to force overwrite" liftIO $ warnl rc $ "Warning: skip already existing file " <> T.pack targetFilename <> ", use -f to force overwrite"
mzero mzero
liftIO $ do liftIO $ do
infol rc $ "Downloading file: " <> respPath rdResp <> ", " infol rc $ "Downloading file: " <> respPath rdResp <> ", "
...@@ -276,7 +276,7 @@ cliApp :: RDOptions -> IO () ...@@ -276,7 +276,7 @@ cliApp :: RDOptions -> IO ()
cliApp opts = do cliApp opts = do
let level = if verbose opts then L.Debug else L.Info let level = if verbose opts then L.Debug else L.Info
-- Note: tinylog doesn't support non-GMT dateformat. -- Note: tinylog doesn't support non-GMT dateformat.
logSettings = (L.setFormat (Just "%Y-%0m-%0dT%0H:%0M:%0S") . logSettings = (L.setFormat (Just L.iso8601) .
L.setLogLevel level . L.setLogLevel level .
L.setDelimiter " ") L.setDelimiter " ")
L.defSettings L.defSettings
...@@ -291,9 +291,9 @@ cliApp opts = do ...@@ -291,9 +291,9 @@ cliApp opts = do
let dir = tempDir opts let dir = tempDir opts
catchIOError (createDirectoryIfMissing True dir) catchIOError (createDirectoryIfMissing True dir)
(\e -> do (\e -> do
errorl rc $ "Create temp dir " <> showt dir <> " failed: " <> showt e errorl rc $ "Create temp dir " <> T.pack dir <> " failed: " <> showt e
exitFailure) exitFailure)
debugl rc $ "using temp dir: " <> showt dir debugl rc $ "using temp dir: " <> T.pack dir
_progressTid <- forkIO $ showProgressLoop rc 0 _progressTid <- forkIO $ showProgressLoop rc 0
-- resultsMaybe :: [Maybe Bool] -- resultsMaybe :: [Maybe Bool]
resultsMaybe <- mapM (runMaybeT . downloadFile rc) (urls opts) resultsMaybe <- mapM (runMaybeT . downloadFile rc) (urls opts)
......
stack.yaml
View file @ 4836bda5
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
# resolver: # resolver:
# name: custom-snapshot # name: custom-snapshot
# location: "./custom-snapshot.yaml" # location: "./custom-snapshot.yaml"
resolver: lts-18.27 resolver: lts-20.26
# A package marked 'extra-dep: true' will only be built if demanded by a # A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks # non-dependency (i.e. a user package), and its test suites and benchmarks
...@@ -28,8 +28,8 @@ packages: ...@@ -28,8 +28,8 @@ packages:
extra-deps: extra-deps:
- git: https://gitlab.emacsos.com/sylecn/io-thread-pool.git - git: https://gitlab.emacsos.com/sylecn/io-thread-pool.git
commit: 58041a07560383bac22f6702074242c3e2097106 commit: 58041a07560383bac22f6702074242c3e2097106
- git: https://gitlab.emacsos.com/sylecn/tinylog.git
# - logger-0.1.0.2 commit: a49750ffb2923d40e834cec77a9900b4167c2ea5
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}
......
test/TestApi.hs
View file @ 4836bda5
...@@ -8,6 +8,8 @@ import Test.Hspec ...@@ -8,6 +8,8 @@ import Test.Hspec
import Test.Hspec.Wai import Test.Hspec.Wai
import Network.Wai.Test import Network.Wai.Test
import Network.HTTP.Types (status200, encodePathSegments, decodePathSegments) import Network.HTTP.Types (status200, encodePathSegments, decodePathSegments)
import qualified Network.HTTP.Client as C
import Network.HTTP.Client (parseRequest)
import Data.Binary.Builder (toLazyByteString) import Data.Binary.Builder (toLazyByteString)
import Network.Wai (Application) import Network.Wai (Application)
import System.FilePath import System.FilePath
...@@ -16,7 +18,8 @@ import System.Directory (removeFile) ...@@ -16,7 +18,8 @@ import System.Directory (removeFile)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.HashMap.Strict as H import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import RD.Lib (sha1sumOnBytes, guessFilename, genBlocks, humanReadableSize) import RD.Lib (sha1sumOnBytes, guessFilename, genBlocks, humanReadableSize)
import RD.Server.Config import RD.Server.Config
...@@ -31,7 +34,7 @@ jsonObject resp = J.decode $ simpleBody resp ...@@ -31,7 +34,7 @@ jsonObject resp = J.decode $ simpleBody resp
jsonKey :: SResponse -> T.Text -> Maybe J.Value jsonKey :: SResponse -> T.Text -> Maybe J.Value
jsonKey resp key = do jsonKey resp key = do
m <- jsonObject resp m <- jsonObject resp
H.lookup key m KM.lookup (K.fromText key) m
jsonKeyAsBool :: SResponse -> T.Text -> Maybe Bool jsonKeyAsBool :: SResponse -> T.Text -> Maybe Bool
jsonKeyAsBool resp key = do jsonKeyAsBool resp key = do
...@@ -55,6 +58,12 @@ spec = do ...@@ -55,6 +58,12 @@ spec = do
describe "3rd party libs" $ do describe "3rd party libs" $ do
it "http-client parseRequest should support unicode in URL" $ do
req <- liftIO $ parseRequest "http://127.0.0.1:8082/中文.txt"
C.host req `shouldBe` "127.0.0.1"
C.port req `shouldBe` 8082
C.path req `shouldBe` (LB.toStrict . toLazyByteString . encodePathSegments) ["中文.txt"]
it "should encode and decode utf-8 characters in URL" $ do it "should encode and decode utf-8 characters in URL" $ do
(decodePathSegments . LB.toStrict . toLazyByteString . encodePathSegments) ["中文1", "路径2"] `shouldBe` ["中文1", "路径2"] (decodePathSegments . LB.toStrict . toLazyByteString . encodePathSegments) ["中文1", "路径2"] `shouldBe` ["中文1", "路径2"]
...@@ -108,17 +117,20 @@ spec = do ...@@ -108,17 +117,20 @@ spec = do
describe "fileRange, hGet n bytes" $ do describe "fileRange, hGet n bytes" $ do
it "should work" $ do it "should work" $ do
contentLB <- liftIO $ fileRange "/home/sylecn/persist/cache/ideaIC-2018.1.tar.gz" 0 2097151 let contentLength = 2400
contentLB <- liftIO $ fileRange "./test/sha1sumFileRange1.dat" 0 contentLength
let first10Byte = LB.take 10 contentLB let first10Byte = LB.take 10 contentLB
sha1sumOnBytes first10Byte `shouldBe` "04bdadb7bd09681ea2d3f84210feff6549b6ab45" sha1sumOnBytes first10Byte `shouldBe` "2059f97d0abc77d255109b52e5240d268225149f"
LB.length contentLB `shouldBe` 2097152 fromIntegral (LB.length contentLB) `shouldBe` contentLength
let last10Byte = LB.drop (2097152 - 10) contentLB let last10Byte = LB.drop (fromIntegral (contentLength - 10)) contentLB
sha1sumOnBytes last10Byte `shouldBe` "c643bc36514fce49013d31f80775dbbc9bf9e9a7" sha1sumOnBytes last10Byte `shouldBe` "d079691750a673076a7d0b5ffaf5371c9981e868"
describe "sha1sumFileRange" $ do describe "sha1sumFileRange" $ do
it "should work" $ do it "should work" $ do
sha1 <- liftIO $ sha1sumFileRange "/home/sylecn/persist/cache/ideaIC-2018.1.tar.gz" 0 2097151 -- to get expected hash,
sha1 `shouldBe` "4690b050834d4059d40ad6f63bf91d6a4558bb71" -- head -c 6 ./test/sha1sumFileRange1.dat |sha1sum
sha1 <- liftIO $ sha1sumFileRange "./test/sha1sumFileRange1.dat" 0 5
sha1 `shouldBe` "1f8ac10f23c5b5bc1167bda84b833e5c057a77d2"
-- | like get, but accept path in [T.Text] format and do url safe encoding. -- | like get, but accept path in [T.Text] format and do url safe encoding.
getPath :: [T.Text] -> WaiSession st SResponse getPath :: [T.Text] -> WaiSession st SResponse
...@@ -146,32 +158,36 @@ apiSpec = with waiApp $ do ...@@ -146,32 +158,36 @@ apiSpec = with waiApp $ do
get "/abc" `shouldRespondWith` 404 get "/abc" `shouldRespondWith` 404
it "should parse basic path correctly" $ do it "should parse basic path correctly" $ do
_resp <- get "/test/rd/abc" _resp <- get "/test-rd/abc"
liftIO (simpleStatus _resp `shouldBe` status200) liftIO (simpleStatus _resp `shouldBe` status200)
liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True) liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc") liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc")
_resp <- get "/test/rd/abc/def" _resp <- get "/test-rd/abc/def"
liftIO (simpleStatus _resp `shouldBe` status200) liftIO (simpleStatus _resp `shouldBe` status200)
liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True) liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc/def") liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc/def")
_resp <- get "/test/rd/abc/def/" _resp <- get "/test-rd/abc/def/"
liftIO (simpleStatus _resp `shouldBe` status200) liftIO (simpleStatus _resp `shouldBe` status200)
liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True) liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc/def/") liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc/def/")
it "should parse complex path correctly" $ do it "should parse complex path correctly" $ do
_resp <- getPath ["test", "rd", "abc def # ? ghi"] _resp <- getPath ["test-rd", "abc def # ? ghi"]
liftIO (simpleStatus _resp `shouldBe` status200) liftIO (simpleStatus _resp `shouldBe` status200)
liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True) liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc def # ? ghi") liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc def # ? ghi")
_resp <- getPath ["test", "rd", "abc/def.jpg"] _resp <- getPath ["test-rd", "abc/def.jpg"]
liftIO (simpleStatus _resp `shouldBe` status200) liftIO (simpleStatus _resp `shouldBe` status200)
liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True) liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc/def.jpg") liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "abc/def.jpg")
-- TODO the escape sequences is not supported by warp. _resp <- getPath ["test-rd", "中文文件名.rar"]
-- _resp <- getPath ["test", "rd", "中文文件名.rar"] liftIO (simpleStatus _resp `shouldBe` status200)
-- liftIO (simpleStatus _resp `shouldBe` status200) liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
-- liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True) liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "中文文件名.rar")
-- liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "中文文件名.rar")
_resp <- getPath ["test-rd", "foo/中文文件名.rar"]
liftIO (simpleStatus _resp `shouldBe` status200)
liftIO (jsonKeyAsBool _resp "ok" `shouldBe` Just True)
liftIO (jsonKeyAsText _resp "path" `shouldBe` Just "foo/中文文件名.rar")
test/sha1sumFileRange1.dat 0 → 100644
View file @ 4836bda5
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz
abcdefg
hijklmn
opqrstu
vwxyz