diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,11 @@ +# Change log for dropbox + +## Version 0.0.0 + ++ Add suppport for + + list folder (see what is in a users folder) + + get temporary link (download file support) + + dropbox token (allow us to get access to a users dropbox) ++ Add basic encoding/decoding tests for datatypes from dropbox api docs ++ import [template](https://github.com/jappeace/haskell-template-project). + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Jappie Klooster + +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/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -0,0 +1,36 @@ +[![Githbu actions build status](https://img.shields.io/github/workflow/status/jappeace/haskell-template-project/Test)](https://github.com/riskbook/dropbox-client/actions) + +> It doesn't actually replace a USB drive. +> +> \- BrandomM on hacker news, commenting on the dropbox idea, 2007 + +This is an incomplete dropbox API client derived from a servant +generic type definition. +Additional endpoints are welcome, feel free to make a PR! + +## History +This is the result from the great riskbook hackathon +of oktober 2020 +(also known as festoberhack). + +## Usage + +### Tools +Enter the nix shell. +``` +nix-shell +``` +You can checkout the makefile to see what's available: +``` +cat makefile +``` + +### Running +``` +make run +``` + +### Fast filewatch which runs tests +``` +make ghcid +``` diff --git a/app/exe.hs b/app/exe.hs new file mode 100644 --- /dev/null +++ b/app/exe.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude (IO, print, (=<<)) +import Dropbox +import Servant.Auth.Client + +token :: Token +token = Token "sl.AkC0dOjbLWtkw7ikA6RePKDX-2Y-7IELqRX0043qMoX1ubN-q3DJ2BxUFR_JFhJKA56dEeKzenxJtFEunQ_Y3gmzsWOir8DBdRxJa1sIIwNLseJIaJ-xKIWH4HBuSLB3RImwlqY" + +main :: IO () +main = do + client <- createClient + print =<< _dropbox_list_folder client token defListFolderRequest diff --git a/dropbox.cabal b/dropbox.cabal new file mode 100644 --- /dev/null +++ b/dropbox.cabal @@ -0,0 +1,96 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack + +name: dropbox +version: 0.0.0 +synopsis: Dropbox API client +description: A dropbox API client generated through servant generic. +category: API +homepage: https://github.com/riskbook/dropbox#readme +bug-reports: https://github.com/riskbook/dropbox/issues +author: Riskbook +maintainer: support@riskbook.com +copyright: 2020 Riskbook +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + Readme.md + LICENSE + Changelog.md + +source-repository head + type: git + location: https://github.com/riskbook/dropbox + +library + exposed-modules: + Dropbox + other-modules: + Paths_dropbox + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities + build-depends: + aeson + , base >=4.7 && <5 + , http-api-data + , http-client-tls + , servant + , servant-auth + , servant-auth-client + , servant-client + , servant-client-core + , text + default-language: Haskell2010 + +executable exe + main-is: exe.hs + other-modules: + Paths_dropbox + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , dropbox + , http-api-data + , http-client-tls + , servant + , servant-auth + , servant-auth-client + , servant-client + , servant-client-core + , text + default-language: Haskell2010 + +test-suite unit + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + DropboxSpec + Test.TestSpec + Paths_dropbox + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities + build-depends: + aeson + , aeson-qq + , base >=4.7 && <5 + , dropbox + , hspec + , hspec-core + , http-api-data + , http-client-tls + , servant + , servant-auth + , servant-auth-client + , servant-client + , servant-client-core + , text + default-language: Haskell2010 diff --git a/src/Dropbox.hs b/src/Dropbox.hs new file mode 100644 --- /dev/null +++ b/src/Dropbox.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | A dropbox client +-- +module Dropbox + ( createClient + , dropboxProxy + , Dropbox(..) + , defListFolderRequest + , FileTag(..) + , Entry(..) + , ListFolderResponse(..) + , ListFolderRequest + , path + , LinkResponse(..) + , LinkRequest(..) + ) where + +import Control.Exception(throwIO) +import Data.Proxy +import Data.Text(Text) +import Network.HTTP.Client.TLS +import Servant.API +import Servant.Client.Generic +import Servant.API.Generic +import Data.Aeson +import Servant.Auth +import Servant.Auth.Client +import Servant.Client +import Web.FormUrlEncoded hiding (fieldLabelModifier) +import Data.Char (isLower) + +toSnake :: String -> String +toSnake = camelTo2 '_' . dropWhile isLower + +data ListFolderRequest = ListFolderRequest + { path :: String + , recursive :: Bool + , include_media_info :: Bool + , include_deleted :: Bool + , include_has_explicit_shared_members :: Bool + , include_mounted_folders :: Bool + , include_non_downloadable_files :: Bool +} deriving (Generic, ToJSON) + +newtype LinkRequest = LinkRequest + { linkPath :: String + } deriving (Generic) + +instance ToJSON LinkRequest where + -- this generates a Value + toJSON (LinkRequest lpath) = + object ["path" .= lpath] + +defListFolderRequest :: ListFolderRequest +defListFolderRequest = ListFolderRequest + { path = "" -- root is empty string in dropbox api + , recursive = False + , include_media_info = False + , include_deleted = False + , include_has_explicit_shared_members = False + , include_mounted_folders = True + , include_non_downloadable_files = False + } + +data FileTag = File | Folder + deriving (Generic, FromJSON, Show, Eq) + +data Entry = Entry + { eTag :: FileTag + , eName :: Text + , ePathDisplay :: Text + , eId :: Text + } deriving (Generic, Show, Eq) + +instance FromJSON Entry where + parseJSON = withObject "Entry" $ \v -> do + tag' :: Text <- v .: ".tag" + let eTag = if tag' == "file" then File else Folder + eName <- v .: "name" + ePathDisplay <- v .: "path_display" + eId <- v .: "id" + pure $ Entry {..} + +newtype ListFolderResponse = ListFolderResponse + { entries :: [Entry] + } deriving (Generic, FromJSON, Show, Eq) + +-- https://www.dropbox.com/developers/documentation/http/documentation#oauth2-token +data TokenRequest = TokenRequest + { trAccessToken :: Text + , trExpiresIn :: Maybe Int -- seconds + , trTokenType :: Text + , trRefreshToken :: Maybe Text + , trScope :: Text + , trAccountId :: Text + , trUid :: Text + } deriving Generic + +snakeConstructor :: Options +snakeConstructor = defaultOptions { constructorTagModifier = camelTo2 '_' } + +snakeLabel :: Options +snakeLabel = snakeConstructor { fieldLabelModifier = toSnake } + +instance FromJSON TokenRequest where + parseJSON = genericParseJSON snakeLabel + +data TokenBody = TokenBody + { code :: Maybe Text + , refresh_token :: Maybe Text + , grant_type :: Text + , redirect_uri :: Text + , client_id :: Text + , client_secret :: Text + } deriving (Generic, Show, ToForm) + +newtype LinkResponse = LinkResponse { + link :: Text + } deriving (Generic, Show, FromJSON) + +-- | To use the various endpoints make sure you have the right +-- scope in your 'app' on dropbox: https://www.dropbox.com/developers/apps/info/t282kls5wbrtofs#permissions +-- then regenerate your token (because it's attached to that) +data Dropbox route = Dropbox + -- TODO: implement list folder + -- | https://www.dropbox.com/developers/documentation/http/documentation#files-list_folder + { _dropbox_list_folder :: route :- "2" :> "files" :> "list_folder" :> Auth '[Bearer] Token :> ReqBody '[JSON] ListFolderRequest :> Post '[JSON] ListFolderResponse + -- | https://www.dropbox.com/developers/documentation/http/documentation#files-get_temporary_link + , _dropbox_get_temporary_link :: route :- "2" :> "files" :> "get_temporary_link" :> Auth '[Bearer] Token :> ReqBody '[JSON] LinkRequest :> Post '[JSON] LinkResponse + , _dropbox_token :: route :- "oauth2" :> "token" :> ReqBody '[FormUrlEncoded] TokenBody :> Post '[JSON] TokenRequest + } deriving Generic + +-- does the generic to type level compute +dropboxProxy :: Proxy (ToServant Dropbox AsApi) +dropboxProxy = genericApi (Proxy @Dropbox) + +-- | gives an adhoc client. This throws exceptions +cliRoutes :: ClientEnv -> Dropbox (AsClientT IO) +cliRoutes env = genericClientHoist + (\x -> runClientM x env >>= either throwIO return) + +createClient :: IO (Dropbox (AsClientT IO)) +createClient = do + baseUri <- parseBaseUrl "https://api.dropboxapi.com/" + manager <- newTlsManager + pure $ cliRoutes $ mkClientEnv manager baseUri diff --git a/test/DropboxSpec.hs b/test/DropboxSpec.hs new file mode 100644 --- /dev/null +++ b/test/DropboxSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module DropboxSpec + ( spec + ) where + +import Dropbox +import Data.Aeson.QQ +import Data.Aeson +import Test.Hspec + +spec :: Spec +spec = do + describe "Dropbox aeson aeson" $ do + it "encodes list folder correctly" $ + encode defListFolderRequest `shouldBe` "{\"include_non_downloadable_files\":false,\"path\":\"\",\"include_mounted_folders\":true,\"include_deleted\":false,\"include_media_info\":false,\"include_has_explicit_shared_members\":false,\"recursive\":false}" + describe "Example response" $ do + it "Decodes correctly" $ fromJSON yyy `shouldBe` Success (ListFolderResponse + [ Entry { eTag = File, eName = "Prime_Numbers.txt", ePathDisplay = "/Homework/math/Prime_Numbers.txt", eId = "id:a4ayc_80_OEAAAAAAAAAXw" } + , Entry { eTag = Folder, eName = "math", ePathDisplay = "/Homework/math", eId = "id:a4ayc_80_OEAAAAAAAAAXz" } + ]) + +yyy :: Value +yyy = [aesonQQ| +{ + "entries": [ + { + ".tag": "file", + "name": "Prime_Numbers.txt", + "id": "id:a4ayc_80_OEAAAAAAAAAXw", + "client_modified": "2015-05-12T15:50:38Z", + "server_modified": "2015-05-12T15:50:38Z", + "rev": "a1c10ce0dd78", + "size": 7212, + "path_lower": "/homework/math/prime_numbers.txt", + "path_display": "/Homework/math/Prime_Numbers.txt", + "sharing_info": { + "read_only": true, + "parent_shared_folder_id": "84528192421", + "modified_by": "dbid:AAH4f99T0taONIb-OurWxbNQ6ywGRopQngc" + }, + "is_downloadable": true, + "property_groups": [ + { + "template_id": "ptid:1a5n2i6d3OYEAAAAAAAAAYa", + "fields": [ + { + "name": "Security Policy", + "value": "Confidential" + } + ] + } + ], + "has_explicit_shared_members": false, + "content_hash": "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855", + "file_lock_info": { + "is_lockholder": true, + "lockholder_name": "Imaginary User", + "created": "2015-05-12T15:50:38Z" + } + }, + { + ".tag": "folder", + "name": "math", + "id": "id:a4ayc_80_OEAAAAAAAAAXz", + "path_lower": "/homework/math", + "path_display": "/Homework/math", + "sharing_info": { + "read_only": false, + "parent_shared_folder_id": "84528192421", + "traverse_only": false, + "no_access": false + }, + "property_groups": [ + { + "template_id": "ptid:1a5n2i6d3OYEAAAAAAAAAYa", + "fields": [ + { + "name": "Security Policy", + "value": "Confidential" + } + ] + } + ] + } + ], + "cursor": "ZtkX9_EHj3x7PMkVuFIhwKYXEpwpLwyxp9vMKomUhllil9q7eWiAu", + "has_more": false +} +|] 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 #-} diff --git a/test/Test/TestSpec.hs b/test/Test/TestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestSpec.hs @@ -0,0 +1,16 @@ +module Test.TestSpec + ( spec + ) +where + +import Test.Hspec + +one :: Int +one = 1 + +spec :: Spec +spec = + describe "The sanity of our test setup" + $ it "should satisfy equality" + $ one + `shouldBe` 1