Fix warnings

This commit is contained in:
Aditya Manthramurthy 2017-01-22 03:48:50 +05:30
parent 72f824dd31
commit 2817d4654d
3 changed files with 14 additions and 26 deletions

View File

@ -66,24 +66,17 @@ parseListObjectsResponse xmldata = do
root = fromDocument doc root = fromDocument doc
s3Elem = element . s3Name s3Elem = element . s3Name
hasMore :: Bool hasMore = ["true"] == (root $/ s3Elem "IsTruncated" &/ content)
hasMore = "true" == (T.concat $ contentOfChildElem root "IsTruncated")
nextToken :: Maybe Text nextToken = headMay $ root $/ s3Elem "NextContinuationToken" &/ content
nextToken = listToMaybe $ contentOfChildElem root "NextContinuationToken"
cPrefTags :: [Cursor] prefixes = root $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
cPrefTags = child root >>= element (s3Name "CommonPrefixes")
prefixes :: [Text]
prefixes = cPrefTags >>= flip contentOfChildElem "Prefix"
keys = root $/ s3Elem "Contents" &/ s3Elem "Key" &/ content keys = root $/ s3Elem "Contents" &/ s3Elem "Key" &/ content
modTimeStr = root $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content modTimeStr = root $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content
etags = root $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content etags = root $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content
sizeStr = root $/ s3Elem "Contents" &/ s3Elem "Size" &/ content sizeStr = root $/ s3Elem "Contents" &/ s3Elem "Size" &/ content
modTimes <- either (throwError . MErrXml) return $ modTimes <- either (throwError . MErrXml) return $
mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack) $ mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack) $
modTimeStr modTimeStr
@ -91,15 +84,10 @@ parseListObjectsResponse xmldata = do
sizes <- forM sizeStr $ \str -> sizes <- forM sizeStr $ \str ->
either (throwError . MErrXml . show) return $ fst <$> decimal str either (throwError . MErrXml . show) return $ fst <$> decimal str
let objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes let
return $ ListObjectsResult hasMore nextToken objects prefixes
where
uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 f (a, b, c, d) = f a b c d uncurry4 f (a, b, c, d) = f a b c d
-- get content of children with given cursor and child-element name. objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
contentOfChildElem :: Cursor -> Text -> [Text]
contentOfChildElem cursor elemName = child cursor >>= return $ ListObjectsResult hasMore nextToken objects prefixes
element (s3Name elemName) >>=
content

View File

@ -22,14 +22,14 @@ testParseLocation = do
-- 1. Test parsing of an invalid location constraint xml. -- 1. Test parsing of an invalid location constraint xml.
parsedLocationE <- runExceptT $ parseLocation "ClearlyInvalidXml" parsedLocationE <- runExceptT $ parseLocation "ClearlyInvalidXml"
case parsedLocationE of case parsedLocationE of
Right loc -> assertFailure $ "Parsing should have failed => " ++ show parsedLocationE Right _ -> assertFailure $ "Parsing should have failed => " ++ show parsedLocationE
Left _ -> return () Left _ -> return ()
forM_ cases $ \(xmldata, expectedLocation) -> do forM_ cases $ \(xmldata, expectedLocation) -> do
parsedLocationE <- runExceptT $ parseLocation xmldata parsedLocationE1 <- runExceptT $ parseLocation xmldata
case parsedLocationE of case parsedLocationE1 of
Right parsedLocation -> parsedLocation @?= expectedLocation Right parsedLocation -> parsedLocation @?= expectedLocation
_ -> assertFailure $ "Parsing failed => " ++ show parsedLocationE _ -> assertFailure $ "Parsing failed => " ++ show parsedLocationE1
where where
cases = [ cases = [
-- 2. Test parsing of a valid location xml. -- 2. Test parsing of a valid location xml.

View File

@ -116,7 +116,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
, funTestWithBucket "Basic listObjects Test" "testbucket3" $ \step bucket -> do , funTestWithBucket "Basic listObjects Test" "testbucket3" $ \step bucket -> do
step "put 10 objects" step "put 10 objects"
forM_ [1..10] $ \s -> forM_ [1..10::Int] $ \s ->
fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release"
step "Simple list" step "Simple list"
@ -125,12 +125,12 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
("lsb-release":) . ("lsb-release":) .
(\x -> [x]) . (\x -> [x]) .
T.pack . T.pack .
show) [1..10] show) [1..10::Int]
liftIO $ assertEqual "Objects match failed!" expected liftIO $ assertEqual "Objects match failed!" expected
(map oiObject $ lorObjects res) (map oiObject $ lorObjects res)
step "cleanup" step "cleanup"
forM_ [1..10] $ \s -> forM_ [1..10::Int] $ \s ->
deleteObject bucket (T.concat ["lsb-release", T.pack (show s)]) deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
] ]