diff --git a/handa-gdata.cabal b/handa-gdata.cabal --- a/handa-gdata.cabal +++ b/handa-gdata.cabal @@ -1,5 +1,5 @@ name: handa-gdata -version: 0.6.5 +version: 0.6.6 cabal-version: >=1.6 -- CHANGELOG: diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -162,7 +162,7 @@ , gshead , gssync ] - &= summary "hgData v0.6.5, (c) 2012-13 Brian W. Bush , MIT license." + &= summary "hgData v0.6.6, (c) 2012-13 Brian W. Bush , MIT license." &= program "hgdata" &= help "Command-line utility for accessing Google services and APIs. Send bug reports and feature requests to ." diff --git a/src/Network/Google.hs b/src/Network/Google.hs --- a/src/Network/Google.hs +++ b/src/Network/Google.hs @@ -112,11 +112,6 @@ -> IO a -- ^ The action returning the result of performing the request. doRequest request = do -{-- - -- TODO: The following seems cleaner, but has type/instance problems: - (_, manager) <- allocate (newManager def) closeManager - doManagedRequest manager request ---} manager <- newManager def E.finally (doManagedRequest manager request) @@ -251,7 +246,7 @@ -- Once the retry list runs out, the last attempt may throw `HttpException` -- exceptions that escape this function. retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a -retryIORequest req retryHook times = loop times +retryIORequest req retryHook = loop where loop [] = req loop (delay:tl) = diff --git a/src/Network/Google/Books.hs b/src/Network/Google/Books.hs --- a/src/Network/Google/Books.hs +++ b/src/Network/Google/Books.hs @@ -22,9 +22,11 @@ ) where -import Network.Google (AccessToken, doRequest, makeRequest) +import Control.Monad (liftM) +import Data.Maybe (fromMaybe) +import Network.Google (AccessToken, appendQuery, doRequest, makeRequest) import Network.HTTP.Conduit (Request) -import Text.JSON (JSObject, JSValue(..), Result(Ok), decode, valFromObj) +import Text.JSON (JSObject, JSValue(..), Result(Ok), decode, fromJSObject, toJSObject, valFromObj) -- | The host for API access. @@ -46,7 +48,7 @@ AccessToken -- ^ The OAuth 2.0 access token. -> IO JSValue -- ^ The action returning the bookshelves' metadata in JSON format. listBookshelves accessToken = - doRequest $ booksRequest accessToken Nothing + doRequest $ booksRequest accessToken Nothing 0 -- | List the bookshelf IDs, see . @@ -90,17 +92,81 @@ -> ShelfId -- ^ The bookshelf ID. -> IO JSValue -- ^ The action returning the books' metadata in JSON format. listShelfBooks accessToken shelf = - doRequest $ booksRequest accessToken (Just shelf) + do + x <- listShelfBooks' accessToken shelf Nothing + let + y :: [JSValue] + y = concatMap items x + JSObject o = head x + z :: [(String, JSValue)] + z = fromJSObject o + u :: [(String, JSValue)] + u = filter (\w -> fst w /= "items") z + v :: [(String, JSValue)] + v = ("items", JSArray y) : u + return $ JSObject $ toJSObject v +-- | List the books in a shelf, see . +listShelfBooks' :: + AccessToken -- ^ The OAuth 2.0 access token. + -> ShelfId -- ^ The bookshelf ID. + -> Maybe Int -- ^ The start index in the list of metadata. + -> IO [JSValue] -- ^ The action returning the books' metadata in JSON format. +listShelfBooks' accessToken shelf startIndex = + do + let + startIndex' :: Int + startIndex' = fromMaybe 0 startIndex + books <- doRequest $ booksRequest accessToken (Just shelf) startIndex' + let + startIndex'' = startIndex' + length (items books) + liftM (books :) $ + if startIndex' + 1 <= totalItems books + then listShelfBooks' accessToken shelf $ Just startIndex'' + else return [] + + +-- | Find the total number of items in a shelf. +totalItems :: + JSValue -- ^ The books' metadata. + -> Int -- ^ The total number of books in the shelf. +totalItems (JSObject books) = + let + Ok count = "totalItems" `valFromObj` books + in + count + + +-- | Find the items in a list of books' metadata. +items :: + JSValue -- ^ The books' metadata + -> [JSValue] -- ^ The books in the metadata. +items (JSObject books) = + let + list = "items" `valFromObj` books + f (Ok x) = x + f _ = [] + in + f list + + -- | Make an HTTP request for Google Books. booksRequest :: AccessToken -- ^ The OAuth 2.0 access token. -> Maybe ShelfId -- ^ The bookshelf ID. + -> Int -- ^ The starting index -> Request m -- ^ The request. -booksRequest accessToken shelf = - makeRequest accessToken booksApi "GET" +booksRequest accessToken shelf startIndex = + appendQuery + [ + ("maxResults", "40") + , ("startIndex", show startIndex) + ] + $ + makeRequest accessToken booksApi "GET" ( booksHost , "/books/v1/mylibrary/bookshelves" ++ maybe "" (\x -> "/" ++ x ++ "/volumes") shelf + ) diff --git a/src/Network/Google/OAuth2.hs b/src/Network/Google/OAuth2.hs --- a/src/Network/Google/OAuth2.hs +++ b/src/Network/Google/OAuth2.hs @@ -340,7 +340,7 @@ let nowsecs = toRational (utcTimeToPOSIXSeconds t) expire1 = start1 + expiresIn toks1 tolerance = 15 * 60 -- Skip refresh if token is good for at least 15 min. - if (expire1 < tolerance + nowsecs) then do + if expire1 < tolerance + nowsecs then do toks2 <- refreshTokens client toks1 timeStampAndWrite tokenF toks2 else return orig diff --git a/src/Network/Google/Storage.hs b/src/Network/Google/Storage.hs --- a/src/Network/Google/Storage.hs +++ b/src/Network/Google/Storage.hs @@ -119,7 +119,7 @@ String -- ^ The unencoded path. -> String -- ^ The URL-encoded path. -- TODO: Review whether the sequence of UTF-8 encoding and URL encoding is correct. This works correctly with tests of exotic unicode sequences, however. -makePath = ('/' :) . intercalate "/" . map (urlEncode . unpack . fromString) . splitOn "/" +makePath = ('/' :) . intercalate "/" . map urlEncode . splitOn "/" -- | List all of the buckets in a specified project. This performs the \"GET Service\" request, see . diff --git a/src/Network/Google/Storage/Sync.hs b/src/Network/Google/Storage/Sync.hs --- a/src/Network/Google/Storage/Sync.hs +++ b/src/Network/Google/Storage/Sync.hs @@ -29,7 +29,7 @@ import qualified Data.ByteString.Lazy as LBS (ByteString, readFile) import qualified Data.Digest.Pure.MD5 as MD5 (md5) import Data.List ((\\), sort) -import Data.Maybe (fromJust, mapMaybe) +import Data.Maybe (catMaybes, fromJust, fromMaybe, mapMaybe) import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (parseTime) @@ -39,7 +39,8 @@ import Network.Google.Storage.Encrypted (putEncryptedObject, putEncryptedObjectUsingManager) import Network.HTTP.Conduit (closeManager, def, newManager) import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (pathSeparator) +import System.FilePath (combine, splitDirectories) +import System.FilePath.Posix (joinPath) import System.IO (hFlush, stdout) import System.Locale (defaultTimeLocale) import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) @@ -212,7 +213,7 @@ else return tokenClock' when md5sums $ - writeFile (directory ++ "/.md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local + writeFile (combine directory ".md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local -- | Delete the first occurrence of items in the second list from the first list, assuming both lists are sorted. @@ -250,7 +251,7 @@ do let eTag' x = if eTag x == md5Empty then Nothing else Just $ eTag x - bytes <- LBS.readFile $ directory ++ [pathSeparator] ++ key' + bytes <- LBS.readFile $ combine directory key' putter key' Nothing bytes (eTag' x) (toAccessToken $ accessToken tokens') return () ) @@ -281,8 +282,10 @@ walkDeleter client tokenClock' deleter xs --- | -handler :: SomeException -> IO () +-- | Exception handler. +handler :: + SomeException -- ^ The exception. + -> IO () -- ^ An empty action. handler exception = putStrLn $ " FAIL " ++ show exception @@ -329,7 +332,7 @@ Bool -- ^ Whether to compute MD5 sums. -> FilePath -- ^ The directory to be synchronized. -> IO [ObjectMetadata] -- ^ Action returning file descriptions. -walkDirectories eTags directory = walkDirectories' eTags (directory ++ [pathSeparator]) [""] +walkDirectories eTags directory = walkDirectories' eTags directory [""] -- | Gather file metadata from the file system. @@ -340,33 +343,38 @@ -> IO [ObjectMetadata] -- ^ Action returning file descriptions. walkDirectories' _ _ [] = return [] walkDirectories' eTags directory (y : ys) = - handle - (( - \exception -> - do - putStrLn $ " LIST " ++ y - putStrLn $ " FAIL " ++ show exception - walkDirectories' eTags directory ys - ) :: SomeException -> IO [ObjectMetadata]) - ( - do - let - makeMetadata :: FilePath -> IO ObjectMetadata - makeMetadata file = - do - let - key = tail file - path = directory ++ key - bytes <- LBS.readFile path - status <- getFileStatus path - let - !lastTime = posixSecondsToUTCTime $ realToFrac $ modificationTime status - !size = fromIntegral $ fileSize status - !eTag = if eTags then md5Base64 bytes else md5Empty - return $ ObjectMetadata key eTag size lastTime - files <- liftM (map ((y ++ [pathSeparator]) ++) . ( \\ [".", ".."])) - $ getDirectoryContents (directory ++ y) - y' <- filterM (doesDirectoryExist . (directory ++)) files - x' <- mapM makeMetadata $ files \\ y' - liftM (x' ++) $ walkDirectories' eTags directory (y' ++ ys) - ) + do + let + handler :: a -> SomeException -> IO a + handler def exception = + do + putStrLn $ " LIST " ++ y + putStrLn $ " FAIL " ++ show exception + return def + makeMetadata :: FilePath -> IO (Maybe ObjectMetadata) + makeMetadata file = + handle + (handler Nothing) + ( + do + let + key = (joinPath . splitDirectories) file + path = combine directory key + bytes <- LBS.readFile path + status <- getFileStatus path + let + !lastTime = posixSecondsToUTCTime $ realToFrac $ modificationTime status + !size = fromIntegral $ fileSize status + !eTag = if eTags then md5Base64 bytes else md5Empty + return $ Just $ ObjectMetadata key eTag size lastTime + ) + files <- + handle + (handler []) + ( + liftM (map (combine y) . (\\ [".", ".."])) + $ getDirectoryContents (combine directory y) + ) + y' <- filterM (doesDirectoryExist . combine directory) files + x' <- mapM makeMetadata $ files \\ y' + liftM (catMaybes x' ++) $ walkDirectories' eTags directory (y' ++ ys)