packages feed

google-drive (empty) → 0.1.0

raw patch · 8 files changed

+691/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, conduit, conduit-extra, directory, filepath, google-drive, google-oauth2, hspec, http-conduit, http-types, load-env, mtl, random, resourcet, text, time

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2014 Pat Brisbin <pbrisbin@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ google-drive.cabal view
@@ -0,0 +1,79 @@+Name:                   google-drive+Version:                0.1.0+Author:                 Pat Brisbin <pbrisbin@gmail.com>+Maintainer:             Pat Brisbin <pbrisbin@gmail.com>+License:                MIT+License-File:           LICENSE+Synopsis:               Google Drive API access+Description:+  Interacting with the Google Drive API+  .+  Example usage:+  .+  > import Control.Monad (void)+  > import Data.Conduit (($$+-))+  >+  > import Network.Google.Drive+  >+  > main :: IO ()+  > main = void $ runApi token $ do+  >     root <- getFile "root"+  >     items <- listFiles $ ParentEq (fileId root) `And` Untrashed+  >+  >     mapM_ download items+  >+  >   where+  >     download :: File -> Api ()+  >     download file = do+  >         let fd = fileData file+  >+  >         case fileDownloadUrl $ fd of+  >             Nothing -> return ()+  >             Just url -> getSource (T.unpack url) [] $ \source ->+  >                 source $$+- sinkFile (fileTitle fd)+  .++Cabal-Version:          >= 1.10+Build-Type:             Simple++Library+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+  GHC-Options:          -Wall+  Exposed-Modules:      Network.Google.Api+                      , Network.Google.Drive+                      , Network.Google.Drive.File+                      , Network.Google.Drive.Upload+  Build-Depends:        base            >= 4            && < 5+                      , aeson           >= 0.8          && < 1.0+                      , bytestring+                      , conduit+                      , conduit-extra   >= 1.1.4        && < 1.2+                      , directory+                      , filepath+                      , http-conduit    >= 2.1          && < 2.2+                      , http-types+                      , mtl+                      , random+                      , resourcet+                      , text+                      , time++Test-Suite spec+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  Hs-Source-Dirs:       test+  Ghc-Options:          -Wall+  Main-Is:              Spec.hs+  Build-Depends:        base+                      , hspec+                      , google-drive+                      , google-oauth2+                      , conduit+                      , directory+                      , load-env+                      , text++Source-Repository head+  Type:                 git+  Location:             https://github.com/pbrisbin/google-drive
+ src/Network/Google/Api.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+--+-- Actions for working with any of Google's APIs+--+-- Note: this module may become a standalone package at some point.+--+module Network.Google.Api+    (+    -- * The Api monad+      Api+    , ApiError(..)+    , runApi+    , throwApiError++    -- * HTTP-related types+    , URL+    , Path+    , Params++    -- * High-level requests+    , DownloadSink+    , getJSON+    , getSource+    , postJSON++    -- * Lower-level requests+    , requestJSON+    , requestLbs++    -- * Api helpers+    , authorize+    , decodeBody++    -- * Request helpers+    , addHeader+    , allowStatus+    , setBody+    , setBodySource+    , setMethod++    -- * Re-exports+    , liftIO+    , throwError+    , catchError+    , sinkFile+    ) where++import Control.Applicative ((<$>))+import Control.Monad.Error+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode, encode)+import Data.ByteString (ByteString)+import Data.Conduit+import Data.Conduit.Binary (sinkFile)+import Data.Monoid ((<>))+import GHC.Int (Int64)+import Network.HTTP.Conduit+    ( HttpException(..)+    , Request(..)+    , RequestBody(..)+    , Response(..)+    , http+    , httpLbs+    , parseUrl+    , requestBodySource+    , responseBody+    , setQueryString+    , withManager+    )+import Network.HTTP.Types+    ( Header+    , Method+    , Status+    , hAuthorization+    , hContentType+    )++import qualified Control.Exception as E+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL++-- | Downloads use sinks for space efficiency and so that callers can implement+--   things like throttling or progress output themselves. If you just want to+--   download to a file, use the re-exported @'sinkFile'@+type DownloadSink a =+    ResumableSource (ResourceT IO) ByteString -> ResourceT IO a++data ApiError+    = HttpError HttpException -- ^ Exceptions raised by http-conduit+    | InvalidJSON String      -- ^ Failure to parse a response as JSON+    | GenericError String     -- ^ All other errors++instance Error ApiError where+    strMsg = GenericError++instance Show ApiError where+    show (HttpError ex) = "HTTP Exception: " <> show ex+    show (InvalidJSON msg) = "failure parsing JSON: " <> msg+    show (GenericError msg) = msg++-- | A transformer stack for providing the access token and rescuing errors+type Api = ReaderT String (ErrorT ApiError IO)++-- | Run an @Api@ computation with the given Access token+runApi :: String -- ^ OAuth2 access token+       -> Api a+       -> IO (Either ApiError a)+runApi token f = runErrorT $ runReaderT f token++-- | Abort an @Api@ computation with the given message+throwApiError :: String -> Api a+throwApiError = throwError . GenericError++type URL = String+type Path = String+type Params = [(ByteString, Maybe ByteString)]++-- | Make an authorized GET request for JSON+getJSON :: FromJSON a => URL -> Params -> Api a+getJSON url params = requestJSON url $ setQueryString params++-- | Make an authorized GET request, sending the response to the given sink+getSource :: URL -> Params -> DownloadSink a -> Api a+getSource url params withSource = do+    request <- setQueryString params <$> authorize url++    tryHttp $ withManager $ \manager -> do+        response <- http request manager+        withSource $ responseBody response++-- | Make an authorized POST request for JSON+postJSON :: (ToJSON a, FromJSON b) => URL -> Params -> a -> Api b+postJSON url params body =+    requestJSON url $+        addHeader (hContentType, "application/json") .+        setMethod "POST" .+        setQueryString params .+        setBody (encode body)++-- | Make an authorized request for JSON, first modifying it via the passed+--   function+requestJSON :: FromJSON a => URL -> (Request -> Request) -> Api a+requestJSON url modify = decodeBody =<< requestLbs url modify++-- | Make an authorized request, first modifying it via the passed function, and+--   returning the raw response content+requestLbs :: URL -> (Request -> Request) -> Api (Response BL.ByteString)+requestLbs url modify = do+    request <- authorize url++    tryHttp $ withManager $ httpLbs $ modify request++-- | Create an authorized request for the given URL+authorize :: URL -> Api Request+authorize url = do+    token <- ask+    request <- parseUrl' url++    let authorization = C8.pack $ "Bearer " <> token++    return $ addHeader (hAuthorization, authorization) request++addHeader :: Header -> Request -> Request+addHeader header request =+    request { requestHeaders = header:requestHeaders request }++setMethod :: Method -> Request -> Request+setMethod m request = request { method = m }++setBody :: BL.ByteString -> Request -> Request+setBody bs request = request { requestBody = RequestBodyLBS bs }++setBodySource :: Int64 -> Source (ResourceT IO) ByteString -> Request -> Request+setBodySource len source request =+    request { requestBody = requestBodySource len source }++-- | Modify the Request's status check to not treat the given status as an error+allowStatus :: Status -> Request -> Request+allowStatus status request =+    let original = checkStatus request+        override s r c+            | s == status = Nothing+            | otherwise = original s r c++    in request { checkStatus = override }++-- | Decode a JSON body, capturing failure as an @'ApiError'@+decodeBody :: FromJSON a => Response BL.ByteString -> Api a+decodeBody =+    either (throwError . InvalidJSON) return . eitherDecode . responseBody++parseUrl' :: URL -> Api Request+parseUrl' url = case parseUrl url of+    Just request -> return request+    Nothing -> throwApiError $ "Invalid URL: " <> url++tryHttp :: IO a -> Api a+tryHttp = either (throwError . HttpError) return <=< liftIO . E.try
+ src/Network/Google/Drive.hs view
@@ -0,0 +1,17 @@+-- |+--+-- A convenient re-exporting of all modules+--+module Network.Google.Drive+    ( driveScopes++    -- * Re-exports+    , module X+    ) where++import Network.Google.Api as X+import Network.Google.Drive.File as X+import Network.Google.Drive.Upload as X++driveScopes :: [String]+driveScopes = ["https://www.googleapis.com/auth/drive"]
+ src/Network/Google/Drive/File.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+-- |+--+-- Methods for working with File resources on Google Drive.+--+-- https://developers.google.com/drive/v2/reference/files+--+-- See @"Network.Google.Drive.Upload"@ for uploading files.+--+module Network.Google.Drive.File+    (+    -- * File Resource+      File(..)+    , FileId+    , FileData(..)+    , fileId+    , fileData+    , isFolder+    , localPath+    , uploadMethod+    , uploadPath+    , uploadData++    -- * Search+    , Query(..)+    , Items(..)+    , listFiles++    -- * Actions+    , getFile+    , deleteFile++    -- * Utilities+    , newFile+    , createFolder+    ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (mzero, void)+import Data.Aeson+import Data.ByteString (ByteString)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Time (UTCTime, getCurrentTime)+import Network.HTTP.Types (Method)+import System.Directory (getModificationTime)+import System.FilePath (takeFileName)++import qualified Data.Text as T++import Network.Google.Api++type FileId = Text++-- | Metadata about Files on your Drive+data FileData = FileData+    { fileTitle :: !Text+    , fileModified :: !UTCTime+    , fileParents :: ![FileId]+    , fileTrashed :: !Bool+    , fileSize :: !(Maybe Int)+    , fileDownloadUrl :: !(Maybe Text)+    , fileMimeType :: !Text+    }++data File+    = File FileId FileData -- ^ A File that exists+    | New FileData         -- ^ A File you intend to create++instance Eq File where+    File a _ == File b _ = a == b+    _ == _ = False++instance Show File where+    show (File fi fd) = T.unpack $ fileTitle fd <> " (" <> fi <> ")"+    show (New fd) = show $ File "new" fd++-- | N.B. it is an error to ask for the @fileId@ of a new file+fileId :: File -> FileId+fileId (File x _) = x+fileId _ = error "Cannot get fileId for new File"++fileData :: File -> FileData+fileData (File _ x) = x+fileData (New x) = x++-- | HTTP Method to use for uploading content for this file+uploadMethod :: File -> Method+uploadMethod (File _ _) = "PUT"+uploadMethod (New _) = "POST"++-- | Path to use for uploading content for this file+uploadPath :: File -> Path+uploadPath (File fid _) = "/files/" <> T.unpack fid+uploadPath (New _) = "/files"++-- | HTTP Body to send when uploading content for this file+--+-- Currently a synonym for @fileData@.+--+uploadData :: File -> FileData+uploadData = fileData++-- | What to name this file if downloaded+--+-- Currently just the @fileTitle@+--+localPath :: File -> FilePath+localPath = T.unpack . fileTitle . fileData++newtype Items = Items [File]++instance FromJSON FileData where+    parseJSON (Object o) = FileData+        <$> o .: "title"+        <*> o .: "modifiedDate"+        <*> (mapM (.: "id") =<< o .: "parents")+        <*> ((.: "trashed") =<< o .: "labels")+        <*> (fmap read <$> o .:? "fileSize") -- fileSize is a String!+        <*> o .:? "downloadUrl"+        <*> o .: "mimeType"++    parseJSON _ = mzero++instance FromJSON File where+    parseJSON v@(Object o) = File+        <$> o .: "id"+        <*> parseJSON v++    parseJSON _ = mzero++instance ToJSON FileData where+    toJSON FileData{..} = object+        [ "title" .= fileTitle+        , "modifiedDate" .= fileModified+        , "parents" .= map (\p -> object ["id" .= p]) fileParents+        , "labels" .= object ["trashed" .= fileTrashed]+        , "mimeType" .= fileMimeType+        ]++instance FromJSON Items where+    parseJSON (Object o) = Items <$> (mapM parseJSON =<< o .: "items")+    parseJSON _ = mzero++isFolder :: File -> Bool+isFolder = (== folderMimeType) . fileMimeType . fileData++-- | Search query parameter+--+-- Currently only a small subset of queries are supported+--+data Query+    = TitleEq Text+    | ParentEq FileId+    | Untrashed+    | Query `And` Query+    | Query `Or` Query++baseUrl :: URL+baseUrl = "https://www.googleapis.com/drive/v2"++-- | Get @File@ data by @FileId@+--+-- @\"root\"@ can be used to get information on the Drive itself+--+getFile :: FileId -> Api File+getFile fid = getJSON (baseUrl <> "/files/" <> T.unpack fid) []++-- | Delete a @File@+deleteFile :: File -> Api ()+deleteFile (New _) = return ()+deleteFile (File fid _) = void $ requestLbs+    (baseUrl <> "/files/" <> T.unpack fid) $ setMethod "DELETE"++-- | Perform a search as specified by the @Query@+listFiles :: Query -> Api [File]+listFiles query = do+    Items items <- getJSON (baseUrl <> "/files")+        [ ("q", Just $ toParam query)+        , ("maxResults", Just "1000")+        ]++    return $ items++  where+    toParam :: Query -> ByteString+    toParam (TitleEq title) = "title = " <> quote title+    toParam (ParentEq fid) = quote fid <> " in parents"+    toParam Untrashed = "trashed = false"+    toParam (p `And` q) = "(" <> toParam p <> ") and (" <> toParam q <> ")"+    toParam (p `Or` q) = "(" <> toParam p <> ") or (" <> toParam q <> ")"++    quote :: Text -> ByteString+    quote = ("'" <>) . (<> "'") . encodeUtf8++-- | Build a new @File@+--+-- N.B. This does not create the file.+--+-- The file is defined as within the given parent, and has some information+-- (currently title and modified) taken from the local file+--+newFile :: FileId   -- ^ Parent+        -> FilePath+        -> Api File+newFile parent filePath = do+    modified <- liftIO $ getModificationTime filePath++    return $ New $ FileData+        { fileTitle = T.pack $ takeFileName filePath+        , fileModified = modified+        , fileParents = [parent]+        , fileTrashed = False+        , fileSize = Nothing+        , fileDownloadUrl = Nothing+        , fileMimeType = ""+        }++-- | Create a new remote folder+createFolder :: FileId -- ^ Parent+             -> Text   -- ^ Title to give the folder+             -> Api File+createFolder parent title = do+    modified <- liftIO $ getCurrentTime++    postJSON (baseUrl <> "/files") [] $ FileData+        { fileTitle = title+        , fileModified = modified+        , fileParents = [parent]+        , fileTrashed = False+        , fileSize = Nothing+        , fileDownloadUrl = Nothing+        , fileMimeType = folderMimeType+        }++folderMimeType :: Text+folderMimeType = "application/vnd.google-apps.folder"
+ src/Network/Google/Drive/Upload.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+--+-- Resumable uploads+--+-- https://developers.google.com/drive/web/manage-uploads#resumable+--+-- Note: actual resuming of uploads on errors is currently untested.+--+module Network.Google.Drive.Upload+    ( UploadSource+    , uploadSourceFile+    , uploadFile+    ) where++import Control.Concurrent (threadDelay)+import Control.Monad.Trans.Resource (ResourceT)+import Data.Aeson+import Data.ByteString (ByteString)+import Data.Conduit+import Data.Conduit.Binary (sourceFile, sourceFileRange)+import Data.List (stripPrefix)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Network.HTTP.Conduit+import Network.HTTP.Types+    ( Status+    , hContentLength+    , hContentType+    , hLocation+    , hRange+    , mkStatus+    , statusIsServerError+    )+import System.Random (randomRIO)++import qualified Data.ByteString.Char8 as C8++import Network.Google.Api+import Network.Google.Drive.File++-- | Uploads use sources for space efficiency and so that callers can implement+--   things like throttling or progress output themselves. Since uploads are+--   resumable, each invocation will give your @UploadSource@ the bytes+--   completed so far, so you may create an appropriately offset source (i.e.+--   into a file).+type UploadSource = Int -> Source (ResourceT IO) ByteString++-- | Simple @UploadSource@ for uploading from a file+uploadSourceFile :: FilePath -> UploadSource+uploadSourceFile fp 0 = sourceFile fp+uploadSourceFile fp c = sourceFileRange fp (Just $ fromIntegral $ c + 1) Nothing++baseUrl :: URL+baseUrl = "https://www.googleapis.com/upload/drive/v2"++uploadFile :: File -- ^ New or existing @File@+           -> Int  -- ^ Length of source+           -> UploadSource+           -> Api File+uploadFile file fileLength mkSource =+    withSessionUrl file $ \url -> do+        retryWithBackoff 1 $ do+            completed <- getUploadedBytes url+            resumeUpload url completed fileLength mkSource++withSessionUrl :: File -> (URL -> Api b) -> Api b+withSessionUrl file action  = do+    response <- requestLbs (baseUrl <> uploadPath file) $+        setMethod (uploadMethod file) .+        setQueryString uploadQuery .+        setBody (encode $ uploadData file) .+        addHeader (hContentType, "application/json")++    case lookup hLocation $ responseHeaders response of+        Just url -> action $ C8.unpack url+        Nothing -> throwApiError "Resumable upload Location header missing"++  where+    uploadQuery :: Params+    uploadQuery =+        [ ("uploadType", Just "resumable")+        , ("setModifiedDate", Just "true")+        ]++getUploadedBytes :: URL -> Api Int+getUploadedBytes url = do+    response <- requestLbs url $+        setMethod "PUT" .+        addHeader (hContentLength, "0") .+        addHeader ("Content-Range", "bytes */*") .+        allowStatus status308++    return $ fromMaybe 0 $ rangeEnd =<< lookup hRange (responseHeaders response)++  where+    rangeEnd :: ByteString -> Maybe Int+    rangeEnd = fmap read . stripPrefix "0-" . C8.unpack++resumeUpload :: URL -> Int -> Int -> UploadSource -> Api File+resumeUpload url completed fileLength mkSource = do+    let left = fileLength - completed++    requestJSON url $+        setMethod "PUT" .+        addRange completed .+        setBodySource (fromIntegral left) (mkSource completed)++  where+    addRange 0 = id+    addRange c = addHeader ("Content-Range", nextRange c fileLength)++    -- e.g. Content-Range: bytes 43-1999999/2000000+    nextRange c t = C8.pack $+        "bytes " <> show (c + 1) <> "-" <> show (t - 1) <> "/" <> show t++retryWithBackoff :: Int -> Api a -> Api a+retryWithBackoff seconds f = f `catchError` \e ->+    if seconds < 16 && retryable e+        then delay >> retryWithBackoff (seconds * 2) f+        else throwError e++  where+    retryable :: ApiError -> Bool+    retryable (HttpError (StatusCodeException s _ _)) = statusIsServerError s+    retryable _ = False++    delay :: Api ()+    delay = liftIO $ do+        ms <- randomRIO (0, 999)+        threadDelay $ (seconds * 1000 + ms) * 1000++status308 :: Status+status308 = mkStatus 308 "Resume Incomplete"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}