diff --git a/google-drive.cabal b/google-drive.cabal --- a/google-drive.cabal +++ b/google-drive.cabal @@ -1,5 +1,5 @@ Name: google-drive -Version: 0.2.0 +Version: 0.3.0 Author: Pat Brisbin Maintainer: Pat Brisbin License: MIT @@ -8,29 +8,7 @@ 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) + See https://github.com/pbrisbin/google-drive for usage and details. . Cabal-Version: >= 1.10 @@ -43,6 +21,7 @@ Exposed-Modules: Network.Google.Api , Network.Google.Drive , Network.Google.Drive.File + , Network.Google.Drive.Search , Network.Google.Drive.Upload Build-Depends: base >= 4 && < 5 , aeson >= 0.8 && < 1.0 @@ -69,10 +48,13 @@ , hspec , google-drive , google-oauth2 + , bytestring , conduit + , conduit-extra , directory , load-env , text + , time Source-Repository head Type: git diff --git a/src/Network/Google/Api.hs b/src/Network/Google/Api.hs --- a/src/Network/Google/Api.hs +++ b/src/Network/Google/Api.hs @@ -25,6 +25,7 @@ , getJSON , getSource , postJSON + , putJSON -- * Lower-level requests , requestJSON @@ -151,6 +152,15 @@ requestJSON url $ addHeader (hContentType, "application/json") . setMethod "POST" . + setQueryString params . + setBody (encode body) + +-- | Make an authorized PUT request for JSON +putJSON :: (ToJSON a, FromJSON b) => URL -> Params -> a -> Api b +putJSON url params body = + requestJSON url $ + addHeader (hContentType, "application/json") . + setMethod "PUT" . setQueryString params . setBody (encode body) diff --git a/src/Network/Google/Drive.hs b/src/Network/Google/Drive.hs --- a/src/Network/Google/Drive.hs +++ b/src/Network/Google/Drive.hs @@ -11,7 +11,9 @@ import Network.Google.Api as X import Network.Google.Drive.File as X +import Network.Google.Drive.Search as X import Network.Google.Drive.Upload as X +-- | OAuth2 scopes to use for access to the Drive API 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 --- a/src/Network/Google/Drive/File.hs +++ b/src/Network/Google/Drive/File.hs @@ -6,7 +6,8 @@ -- -- https://developers.google.com/drive/v2/reference/files -- --- See @"Network.Google.Drive.Upload"@ for uploading files. +-- This module is mostly concerned with creating and updating metadata. See +-- @"Network.Google.Drive.Upload"@ for uploading content. -- module Network.Google.Drive.File ( @@ -14,49 +15,48 @@ File(..) , FileId , FileData(..) - , fileId - , fileData - , isFolder - , localPath - , uploadMethod - , uploadPath - , uploadData + , FileTitle - -- * Search - , Query(..) - , Items(..) - , listFiles + -- * Building @File@s + , newFile + , newFolder + , setParent + , setMimeType -- * Actions , getFile + , createFile + , updateFile , deleteFile + , downloadFile -- * Utilities - , newFile - , createFolder + , isFolder + , isDownloadable + , localPath ) where +import Network.Google.Api + import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero, void) import Data.Aeson -import Data.ByteString (ByteString) +import Data.Maybe (isJust) 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 Data.Time (UTCTime) +import Network.HTTP.Conduit (HttpException(..)) +import Network.HTTP.Types (status404) +import qualified Data.Traversable as F import qualified Data.Text as T -import Network.Google.Api - type FileId = Text +type FileTitle = Text -- | Metadata about Files on your Drive data FileData = FileData - { fileTitle :: !Text + { fileTitle :: !FileTitle , fileModified :: !UTCTime , fileParents :: ![FileId] , fileTrashed :: !Bool @@ -65,52 +65,17 @@ , fileMimeType :: !Text } -data File - = File FileId FileData -- ^ A File that exists - | New FileData -- ^ A File you intend to create +-- | An existing file +data File = File + { fileId :: FileId + , fileData :: FileData + } instance Eq File where - File a _ == File b _ = a == b - _ == _ = False + a == b = fileId a == fileId b 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] + show f = localPath f <> " (" <> T.unpack (fileId f) <> ")" instance FromJSON FileData where parseJSON (Object o) = FileData @@ -124,13 +89,6 @@ 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 @@ -140,100 +98,89 @@ , "mimeType" .= fileMimeType ] -instance FromJSON Items where - parseJSON (Object o) = Items <$> (mapM parseJSON =<< o .: "items") +instance FromJSON File where + parseJSON v@(Object o) = File + <$> o .: "id" + <*> parseJSON v parseJSON _ = mzero -isFolder :: File -> Bool -isFolder = (== folderMimeType) . fileMimeType . fileData - --- | Search query parameter +-- | Get a @File@ data by @FileId@ -- --- Currently only a small subset of queries are supported +-- @\"root\"@ can be used to get information on the Drive itself -- -data Query - = TitleEq Text - | ParentEq FileId - | Untrashed - | Query `And` Query - | Query `Or` Query +-- If the API returns 404, this returns @Nothing@ +-- +getFile :: FileId -> Api (Maybe File) +getFile fid = (Just <$> getJSON (fileUrl fid) []) + `catchError` handleNotFound -baseUrl :: URL -baseUrl = "https://www.googleapis.com/drive/v2" + where + handleNotFound (HttpError (StatusCodeException s _ _)) + | s == status404 = return Nothing + handleNotFound e = throwError e --- | 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) [] +-- | Create a @File@ from @FileData@ +createFile :: FileData -> Api File +createFile fd = + postJSON (baseUrl <> "/files") [("setModifiedDate", Just "true")] fd +-- | Update a @File@ +updateFile :: FileId -> FileData -> Api File +updateFile fid fd = + putJSON (fileUrl $ fid) [("setModifiedDate", Just "true")] fd + -- | Delete a @File@ deleteFile :: File -> Api () -deleteFile (New _) = return () -deleteFile (File fid _) = void $ requestLbs - (baseUrl <> "/files/" <> T.unpack fid) $ setMethod "DELETE" +deleteFile f = void $ requestLbs (fileUrl $ fileId f) $ 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") - ] +-- | Download a @File@ +-- +-- Returns @Nothing@ if the file is not downloadable +-- +downloadFile :: File -> DownloadSink a -> Api (Maybe a) +downloadFile f sink = F.forM (fileDownloadUrl $ fileData f) $ \url -> + getSource (T.unpack url) [] sink - return items +newFile :: FileTitle -> UTCTime -> FileData +newFile title modified = FileData + { fileTitle = title + , fileModified = modified + , fileParents = [] + , fileTrashed = False + , fileSize = Nothing + , fileDownloadUrl = Nothing + , fileMimeType = "" + } - 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 <> ")" +newFolder :: FileTitle -> UTCTime -> FileData +newFolder title = setMimeType folderMimeType . newFile title - quote :: Text -> ByteString - quote = ("'" <>) . (<> "'") . encodeUtf8 +setParent :: File -> FileData -> FileData +setParent p f = f { fileParents = [fileId p] } --- | Build a new @File@ --- --- N.B. This does not create the file. +setMimeType :: Text -> FileData -> FileData +setMimeType m f = f { fileMimeType = m } + +-- | What to name this file if downloaded -- --- The file is defined as within the given parent, and has some information --- (currently title and modified) taken from the local file +-- Currently just the @fileTitle@ -- -newFile :: FileId -- ^ Parent - -> FilePath - -> Api File -newFile parent filePath = do - modified <- liftIO $ getModificationTime filePath +localPath :: File -> FilePath +localPath = T.unpack . fileTitle . fileData - return $ New FileData - { fileTitle = T.pack $ takeFileName filePath - , fileModified = modified - , fileParents = [parent] - , fileTrashed = False - , fileSize = Nothing - , fileDownloadUrl = Nothing - , fileMimeType = "" - } +-- | Check if a @File@ is a folder by inspecting its mime-type +isFolder :: File -> Bool +isFolder = (== folderMimeType) . fileMimeType . fileData --- | Create a new remote folder -createFolder :: FileId -- ^ Parent - -> Text -- ^ Title to give the folder - -> Api File -createFolder parent title = do - modified <- liftIO getCurrentTime +-- | Check if a @File@ has content stored in drive +isDownloadable :: File -> Bool +isDownloadable = isJust . fileDownloadUrl . fileData - postJSON (baseUrl <> "/files") [] FileData - { fileTitle = title - , fileModified = modified - , fileParents = [parent] - , fileTrashed = False - , fileSize = Nothing - , fileDownloadUrl = Nothing - , fileMimeType = folderMimeType - } +baseUrl :: URL +baseUrl = "https://www.googleapis.com/drive/v2" + +fileUrl :: FileId -> URL +fileUrl fid = baseUrl <> "/files/" <> T.unpack fid folderMimeType :: Text folderMimeType = "application/vnd.google-apps.folder" diff --git a/src/Network/Google/Drive/Search.hs b/src/Network/Google/Drive/Search.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Drive/Search.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- Searching for files on your drive. +-- +-- https://developers.google.com/drive/web/search-parameters +-- +module Network.Google.Drive.Search + ( listFiles + , listVisibleContents + + -- * Building Queries + , Query + , Field(..) + , QueryValue(..) + , (?=) + , (?!=) + , (?<) + , (?<=) + , (?>) + , (?>=) + , qIn + , qHas + , qContains + , qAnd + , qOr + , qNot + ) where + +import Network.Google.Api +import Network.Google.Drive.File + +import Control.Applicative ((<$>), (<$>)) +import Control.Monad (mzero) +import Data.Aeson +import Data.Char (toLower) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + +import qualified Data.Text as T + +type Query = Text + +-- | Queriable fields +data Field + = Title + | FullText + | MimeType + | ModifiedDate + | LastViewedByMeDate + | Trashed + | Starred + | Parents + | Owners + | Writers + | Readers + | SharedWithMe + | Properties + deriving Show + +-- | Type class for values which can be used in queries +class QueryValue a where + escapeValue :: a -> Text + +instance QueryValue Text where + escapeValue t = "'" <> t <> "'" + +instance QueryValue Bool where + escapeValue True = "true" + escapeValue False = "false" + +-- TODO +-- instance QueryValue UTCTime where +-- RFC 3339 format, default timezone is UTC, e.g., 2012-06-04T12:00:00-08:00. + +newtype Items = Items [File] + +instance FromJSON Items where + parseJSON (Object o) = Items <$> (mapM parseJSON =<< o .: "items") + parseJSON _ = mzero + +-- | Perform a search as specified by the @Query@ +listFiles :: Query -> Api [File] +listFiles query = do + Items items <- getJSON (baseUrl <> "/files") + [ ("q", Just $ encodeUtf8 query) + , ("maxResults", Just "1000") + ] + + return items + +-- | List all not-trashed files within the given folder +listVisibleContents :: File -> Api [File] +listVisibleContents folder = + listFiles $ (fileId folder) `qIn` Parents `qAnd` Trashed ?= False + +-- | The content of a string or boolean is equal to the other +(?=) :: QueryValue a => Field -> a -> Query +(?=) = qOp "=" + +-- | The content of a string or boolean is not equal to the other +(?!=) :: QueryValue a => Field -> a -> Query +(?!=) = qOp "!=" + +-- | A date is earlier than another +(?<) :: QueryValue a => Field -> a -> Query +(?<) = qOp "<" + +-- | A date is earlier than or equal to another +(?<=) :: QueryValue a => Field -> a -> Query +(?<=) = qOp "<=" + +-- | A date is later than another +(?>) :: QueryValue a => Field -> a -> Query +(?>) = qOp ">" + +-- | A date is later than or equal to another +(?>=) :: QueryValue a => Field -> a -> Query +(?>=) = qOp ">=" + +-- | An element is contained within a collection +-- +-- Used for @Parents@, @Owners@, @Writers@, and @Readers@. +-- +-- Note the reversed arguments such that infix usage makes sense. +-- +qIn :: QueryValue a => a -> Field -> Query +qIn v f = T.intercalate " " [escapeValue v, "in", escapeField f] + +-- | A collection contains an element matching the parameters. +-- +-- Used for @Properties@. +-- +qHas :: QueryValue a => Field -> a -> Query +qHas = qOp "has" + +-- | The content of one string is present in the other +-- +-- Used for @Title@, @FullText@, and @MimeType@. +-- +qContains :: QueryValue a => Field -> a -> Query +qContains = qOp "contains" + +infixr 3 `qAnd` + +-- | Return files that match both clauses +qAnd :: Query -> Query -> Query +q `qAnd` p = "(" <> p <> ") and (" <> q <> ")" + +infixr 2 `qOr` + +-- | Return files that match either clause +qOr :: Query -> Query -> Query +q `qOr` p = "(" <> p <> ") or (" <> q <> ")" + +-- | Negates a search clause +qNot :: Query -> Query +qNot q = "not " <> "(" <> q <> ")" + +qOp :: QueryValue a => Text -> Field -> a -> Query +qOp x f v = T.intercalate " " [escapeField f, x, escapeValue v] + +escapeField :: Field -> Text +escapeField = T.pack . lowerCase . show + where + lowerCase [] = [] + lowerCase (x:xs) = toLower x : xs + +baseUrl :: URL +baseUrl = "https://www.googleapis.com/drive/v2" diff --git a/src/Network/Google/Drive/Upload.hs b/src/Network/Google/Drive/Upload.hs --- a/src/Network/Google/Drive/Upload.hs +++ b/src/Network/Google/Drive/Upload.hs @@ -10,7 +10,8 @@ module Network.Google.Drive.Upload ( UploadSource , uploadSourceFile - , uploadFile + , createFileWithContent + , updateFileWithContent ) where import Control.Concurrent (threadDelay) @@ -24,7 +25,8 @@ import Data.Monoid ((<>)) import Network.HTTP.Conduit import Network.HTTP.Types - ( Status + ( Method + , Status , hContentLength , hContentType , hLocation @@ -35,6 +37,7 @@ import System.Random (randomRIO) import qualified Data.ByteString.Char8 as C8 +import qualified Data.Text as T import Network.Google.Api import Network.Google.Drive.File @@ -51,25 +54,26 @@ 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" +createFileWithContent :: FileData -> Int -> UploadSource -> Api File +createFileWithContent = uploadContent "POST" "/files" -uploadFile :: File -- ^ New or existing @File@ - -> Int -- ^ Length of source - -> UploadSource - -> Api File -uploadFile file fileLength mkSource = - withSessionUrl file $ \url -> +updateFileWithContent :: FileId -> FileData -> Int -> UploadSource -> Api File +updateFileWithContent fid fd = + uploadContent "PUT" ("/files/" <> T.unpack fid) $ fd + +uploadContent :: Method -> Path -> FileData -> Int -> UploadSource -> Api File +uploadContent m p fd fl mkSource = + withSessionUrl m p fd $ \url -> retryWithBackoff 1 $ do completed <- getUploadedBytes url - resumeUpload url completed fileLength mkSource + resumeUpload url completed fl mkSource -withSessionUrl :: File -> (URL -> Api b) -> Api b -withSessionUrl file action = do - response <- requestLbs (baseUrl <> uploadPath file) $ - setMethod (uploadMethod file) . +withSessionUrl :: Method -> Path -> FileData -> (URL -> Api a) -> Api a +withSessionUrl m p fd action = do + response <- requestLbs (baseUrl <> p) $ + setMethod m . setQueryString uploadQuery . - setBody (encode $ uploadData file) . + setBody (encode fd) . addHeader (hContentType, "application/json") case lookup hLocation $ responseHeaders response of @@ -129,6 +133,9 @@ delay = liftIO $ do ms <- randomRIO (0, 999) threadDelay $ (seconds * 1000 + ms) * 1000 + +baseUrl :: URL +baseUrl = "https://www.googleapis.com/upload/drive/v2" status308 :: Status status308 = mkStatus 308 "Resume Incomplete"