diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2014 Pat Brisbin + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/google-drive.cabal b/google-drive.cabal new file mode 100644 --- /dev/null +++ b/google-drive.cabal @@ -0,0 +1,79 @@ +Name: google-drive +Version: 0.1.0 +Author: Pat Brisbin +Maintainer: Pat Brisbin +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 diff --git a/src/Network/Google/Api.hs b/src/Network/Google/Api.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Api.hs @@ -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 diff --git a/src/Network/Google/Drive.hs b/src/Network/Google/Drive.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Drive.hs @@ -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"] diff --git a/src/Network/Google/Drive/File.hs b/src/Network/Google/Drive/File.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Drive/File.hs @@ -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" diff --git a/src/Network/Google/Drive/Upload.hs b/src/Network/Google/Drive/Upload.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Drive/Upload.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}