{-# 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
  , cliRoutes
  , Dropbox(..)
  , defListFolderRequest
  , FileTag(..)
  , Entry(..)
  , ListFolderResponse(..)
  , ListFolderRequest
  , path
  , LinkResponse(..)
  , LinkRequest(..)
  , TokenRequest(..)
  , TokenBody(..)
  , dropboxProxy
  ) 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 :: String -> String
toSnake = Char -> String -> String
camelTo2 '_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isLower

data ListFolderRequest = ListFolderRequest
  { ListFolderRequest -> String
path :: String
  , ListFolderRequest -> Bool
recursive :: Bool
  , ListFolderRequest -> Bool
include_media_info :: Bool
  , ListFolderRequest -> Bool
include_deleted :: Bool
  , ListFolderRequest -> Bool
include_has_explicit_shared_members :: Bool
  , ListFolderRequest -> Bool
include_mounted_folders :: Bool
  , ListFolderRequest -> Bool
include_non_downloadable_files :: Bool
} deriving ((forall x. ListFolderRequest -> Rep ListFolderRequest x)
-> (forall x. Rep ListFolderRequest x -> ListFolderRequest)
-> Generic ListFolderRequest
forall x. Rep ListFolderRequest x -> ListFolderRequest
forall x. ListFolderRequest -> Rep ListFolderRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ListFolderRequest x -> ListFolderRequest
$cfrom :: forall x. ListFolderRequest -> Rep ListFolderRequest x
Generic, [ListFolderRequest] -> Encoding
[ListFolderRequest] -> Value
ListFolderRequest -> Encoding
ListFolderRequest -> Value
(ListFolderRequest -> Value)
-> (ListFolderRequest -> Encoding)
-> ([ListFolderRequest] -> Value)
-> ([ListFolderRequest] -> Encoding)
-> ToJSON ListFolderRequest
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ListFolderRequest] -> Encoding
$ctoEncodingList :: [ListFolderRequest] -> Encoding
toJSONList :: [ListFolderRequest] -> Value
$ctoJSONList :: [ListFolderRequest] -> Value
toEncoding :: ListFolderRequest -> Encoding
$ctoEncoding :: ListFolderRequest -> Encoding
toJSON :: ListFolderRequest -> Value
$ctoJSON :: ListFolderRequest -> Value
ToJSON)

newtype LinkRequest = LinkRequest
  { LinkRequest -> String
linkPath :: String
  } deriving ((forall x. LinkRequest -> Rep LinkRequest x)
-> (forall x. Rep LinkRequest x -> LinkRequest)
-> Generic LinkRequest
forall x. Rep LinkRequest x -> LinkRequest
forall x. LinkRequest -> Rep LinkRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LinkRequest x -> LinkRequest
$cfrom :: forall x. LinkRequest -> Rep LinkRequest x
Generic)

instance ToJSON LinkRequest where
    -- this generates a Value
    toJSON :: LinkRequest -> Value
toJSON (LinkRequest lpath :: String
lpath) =
        [Pair] -> Value
object ["path" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
lpath]

defListFolderRequest :: ListFolderRequest
defListFolderRequest :: ListFolderRequest
defListFolderRequest = ListFolderRequest :: String
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> ListFolderRequest
ListFolderRequest
  { path :: String
path = "" -- root is empty string in dropbox api
  , recursive :: Bool
recursive = Bool
False
  , include_media_info :: Bool
include_media_info = Bool
False
  , include_deleted :: Bool
include_deleted = Bool
False
  , include_has_explicit_shared_members :: Bool
include_has_explicit_shared_members = Bool
False
  , include_mounted_folders :: Bool
include_mounted_folders = Bool
True
  , include_non_downloadable_files :: Bool
include_non_downloadable_files = Bool
False
  }

data FileTag = File | Folder
  deriving ((forall x. FileTag -> Rep FileTag x)
-> (forall x. Rep FileTag x -> FileTag) -> Generic FileTag
forall x. Rep FileTag x -> FileTag
forall x. FileTag -> Rep FileTag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileTag x -> FileTag
$cfrom :: forall x. FileTag -> Rep FileTag x
Generic, Value -> Parser [FileTag]
Value -> Parser FileTag
(Value -> Parser FileTag)
-> (Value -> Parser [FileTag]) -> FromJSON FileTag
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FileTag]
$cparseJSONList :: Value -> Parser [FileTag]
parseJSON :: Value -> Parser FileTag
$cparseJSON :: Value -> Parser FileTag
FromJSON, Int -> FileTag -> String -> String
[FileTag] -> String -> String
FileTag -> String
(Int -> FileTag -> String -> String)
-> (FileTag -> String)
-> ([FileTag] -> String -> String)
-> Show FileTag
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileTag] -> String -> String
$cshowList :: [FileTag] -> String -> String
show :: FileTag -> String
$cshow :: FileTag -> String
showsPrec :: Int -> FileTag -> String -> String
$cshowsPrec :: Int -> FileTag -> String -> String
Show, FileTag -> FileTag -> Bool
(FileTag -> FileTag -> Bool)
-> (FileTag -> FileTag -> Bool) -> Eq FileTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileTag -> FileTag -> Bool
$c/= :: FileTag -> FileTag -> Bool
== :: FileTag -> FileTag -> Bool
$c== :: FileTag -> FileTag -> Bool
Eq)

data Entry = Entry
  { Entry -> FileTag
eTag :: FileTag
  , Entry -> Text
eName :: Text
  , Entry -> Text
ePathDisplay :: Text
  , Entry -> Text
eId :: Text
  } deriving ((forall x. Entry -> Rep Entry x)
-> (forall x. Rep Entry x -> Entry) -> Generic Entry
forall x. Rep Entry x -> Entry
forall x. Entry -> Rep Entry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Entry x -> Entry
$cfrom :: forall x. Entry -> Rep Entry x
Generic, Int -> Entry -> String -> String
[Entry] -> String -> String
Entry -> String
(Int -> Entry -> String -> String)
-> (Entry -> String) -> ([Entry] -> String -> String) -> Show Entry
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Entry] -> String -> String
$cshowList :: [Entry] -> String -> String
show :: Entry -> String
$cshow :: Entry -> String
showsPrec :: Int -> Entry -> String -> String
$cshowsPrec :: Int -> Entry -> String -> String
Show, Entry -> Entry -> Bool
(Entry -> Entry -> Bool) -> (Entry -> Entry -> Bool) -> Eq Entry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c== :: Entry -> Entry -> Bool
Eq)

instance FromJSON Entry where
  parseJSON :: Value -> Parser Entry
parseJSON = String -> (Object -> Parser Entry) -> Value -> Parser Entry
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "Entry" ((Object -> Parser Entry) -> Value -> Parser Entry)
-> (Object -> Parser Entry) -> Value -> Parser Entry
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> do
    Text
tag' :: Text <- Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: ".tag"
    let eTag :: FileTag
eTag = if Text
tag' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "file" then FileTag
File else FileTag
Folder
    Text
eName <- Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "name"
    Text
ePathDisplay <- Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "path_display"
    Text
eId <- Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "id"
    pure $ Entry :: FileTag -> Text -> Text -> Text -> Entry
Entry {..}

newtype ListFolderResponse = ListFolderResponse
  { ListFolderResponse -> [Entry]
entries :: [Entry]
  } deriving ((forall x. ListFolderResponse -> Rep ListFolderResponse x)
-> (forall x. Rep ListFolderResponse x -> ListFolderResponse)
-> Generic ListFolderResponse
forall x. Rep ListFolderResponse x -> ListFolderResponse
forall x. ListFolderResponse -> Rep ListFolderResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ListFolderResponse x -> ListFolderResponse
$cfrom :: forall x. ListFolderResponse -> Rep ListFolderResponse x
Generic, Value -> Parser [ListFolderResponse]
Value -> Parser ListFolderResponse
(Value -> Parser ListFolderResponse)
-> (Value -> Parser [ListFolderResponse])
-> FromJSON ListFolderResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ListFolderResponse]
$cparseJSONList :: Value -> Parser [ListFolderResponse]
parseJSON :: Value -> Parser ListFolderResponse
$cparseJSON :: Value -> Parser ListFolderResponse
FromJSON, Int -> ListFolderResponse -> String -> String
[ListFolderResponse] -> String -> String
ListFolderResponse -> String
(Int -> ListFolderResponse -> String -> String)
-> (ListFolderResponse -> String)
-> ([ListFolderResponse] -> String -> String)
-> Show ListFolderResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ListFolderResponse] -> String -> String
$cshowList :: [ListFolderResponse] -> String -> String
show :: ListFolderResponse -> String
$cshow :: ListFolderResponse -> String
showsPrec :: Int -> ListFolderResponse -> String -> String
$cshowsPrec :: Int -> ListFolderResponse -> String -> String
Show, ListFolderResponse -> ListFolderResponse -> Bool
(ListFolderResponse -> ListFolderResponse -> Bool)
-> (ListFolderResponse -> ListFolderResponse -> Bool)
-> Eq ListFolderResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListFolderResponse -> ListFolderResponse -> Bool
$c/= :: ListFolderResponse -> ListFolderResponse -> Bool
== :: ListFolderResponse -> ListFolderResponse -> Bool
$c== :: ListFolderResponse -> ListFolderResponse -> Bool
Eq)

data TokenRequest = TokenRequest
  { TokenRequest -> Text
trAccessToken :: Text
  , TokenRequest -> Maybe Int
trExpiresIn :: Maybe Int -- seconds
  , TokenRequest -> Text
trTokenType :: Text
  , TokenRequest -> Maybe Text
trRefreshToken :: Maybe Text
  , TokenRequest -> Text
trScope :: Text
  , TokenRequest -> Text
trAccountId :: Text
  , TokenRequest -> Text
trUid :: Text
  } deriving (forall x. TokenRequest -> Rep TokenRequest x)
-> (forall x. Rep TokenRequest x -> TokenRequest)
-> Generic TokenRequest
forall x. Rep TokenRequest x -> TokenRequest
forall x. TokenRequest -> Rep TokenRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenRequest x -> TokenRequest
$cfrom :: forall x. TokenRequest -> Rep TokenRequest x
Generic

snakeConstructor :: Options
snakeConstructor :: Options
snakeConstructor = Options
defaultOptions { constructorTagModifier :: String -> String
constructorTagModifier = Char -> String -> String
camelTo2 '_' }

snakeLabel :: Options
snakeLabel :: Options
snakeLabel = Options
snakeConstructor { fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
toSnake }

instance FromJSON TokenRequest where
  parseJSON :: Value -> Parser TokenRequest
parseJSON = Options -> Value -> Parser TokenRequest
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
snakeLabel

data TokenBody = TokenBody
  { TokenBody -> Maybe Text
code         :: Maybe Text
  , TokenBody -> Maybe Text
refresh_token :: Maybe Text
  , TokenBody -> Text
grant_type    :: Text
  , TokenBody -> Text
redirect_uri  :: Text
  , TokenBody -> Text
client_id     :: Text
  , TokenBody -> Text
client_secret :: Text
  } deriving ((forall x. TokenBody -> Rep TokenBody x)
-> (forall x. Rep TokenBody x -> TokenBody) -> Generic TokenBody
forall x. Rep TokenBody x -> TokenBody
forall x. TokenBody -> Rep TokenBody x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenBody x -> TokenBody
$cfrom :: forall x. TokenBody -> Rep TokenBody x
Generic, Int -> TokenBody -> String -> String
[TokenBody] -> String -> String
TokenBody -> String
(Int -> TokenBody -> String -> String)
-> (TokenBody -> String)
-> ([TokenBody] -> String -> String)
-> Show TokenBody
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TokenBody] -> String -> String
$cshowList :: [TokenBody] -> String -> String
show :: TokenBody -> String
$cshow :: TokenBody -> String
showsPrec :: Int -> TokenBody -> String -> String
$cshowsPrec :: Int -> TokenBody -> String -> String
Show, TokenBody -> Form
(TokenBody -> Form) -> ToForm TokenBody
forall a. (a -> Form) -> ToForm a
toForm :: TokenBody -> Form
$ctoForm :: TokenBody -> Form
ToForm)

newtype LinkResponse = LinkResponse {
  LinkResponse -> Text
link :: Text
  } deriving ((forall x. LinkResponse -> Rep LinkResponse x)
-> (forall x. Rep LinkResponse x -> LinkResponse)
-> Generic LinkResponse
forall x. Rep LinkResponse x -> LinkResponse
forall x. LinkResponse -> Rep LinkResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LinkResponse x -> LinkResponse
$cfrom :: forall x. LinkResponse -> Rep LinkResponse x
Generic, Int -> LinkResponse -> String -> String
[LinkResponse] -> String -> String
LinkResponse -> String
(Int -> LinkResponse -> String -> String)
-> (LinkResponse -> String)
-> ([LinkResponse] -> String -> String)
-> Show LinkResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LinkResponse] -> String -> String
$cshowList :: [LinkResponse] -> String -> String
show :: LinkResponse -> String
$cshow :: LinkResponse -> String
showsPrec :: Int -> LinkResponse -> String -> String
$cshowsPrec :: Int -> LinkResponse -> String -> String
Show, Value -> Parser [LinkResponse]
Value -> Parser LinkResponse
(Value -> Parser LinkResponse)
-> (Value -> Parser [LinkResponse]) -> FromJSON LinkResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [LinkResponse]
$cparseJSONList :: Value -> Parser [LinkResponse]
parseJSON :: Value -> Parser LinkResponse
$cparseJSON :: Value -> Parser LinkResponse
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 route
-> route
   :- ("2"
       :> ("files"
           :> ("list_folder"
               :> (Auth '[Bearer] Token
                   :> (ReqBody '[JSON] ListFolderRequest
                       :> Post '[JSON] ListFolderResponse)))))
_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 route
-> route
   :- ("2"
       :> ("files"
           :> ("get_temporary_link"
               :> (Auth '[Bearer] Token
                   :> (ReqBody '[JSON] LinkRequest :> Post '[JSON] LinkResponse)))))
_dropbox_get_temporary_link :: route :- "2" :> "files" :> "get_temporary_link" :> Auth '[Bearer] Token :> ReqBody '[JSON] LinkRequest :> Post '[JSON] LinkResponse
  -- | https://www.dropbox.com/developers/documentation/http/documentation#oauth2-token
  , Dropbox route
-> route
   :- ("oauth2"
       :> ("token"
           :> (ReqBody '[FormUrlEncoded] TokenBody
               :> Post '[JSON] TokenRequest)))
_dropbox_token :: route :- "oauth2" :> "token" :> ReqBody '[FormUrlEncoded] TokenBody :> Post '[JSON] TokenRequest
  } deriving (forall x. Dropbox route -> Rep (Dropbox route) x)
-> (forall x. Rep (Dropbox route) x -> Dropbox route)
-> Generic (Dropbox route)
forall x. Rep (Dropbox route) x -> Dropbox route
forall x. Dropbox route -> Rep (Dropbox route) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall route x. Rep (Dropbox route) x -> Dropbox route
forall route x. Dropbox route -> Rep (Dropbox route) x
$cto :: forall route x. Rep (Dropbox route) x -> Dropbox route
$cfrom :: forall route x. Dropbox route -> Rep (Dropbox route) x
Generic

-- does the generic to type level compute
dropboxProxy :: Proxy (ToServant Dropbox AsApi)
dropboxProxy :: Proxy (ToServant Dropbox AsApi)
dropboxProxy = Proxy Dropbox -> Proxy (ToServant Dropbox AsApi)
forall (routes :: * -> *).
GenericServant routes AsApi =>
Proxy routes -> Proxy (ToServantApi routes)
genericApi (Proxy Dropbox
forall k (t :: k). Proxy t
Proxy @Dropbox)

-- | gives an adhoc client. This throws exceptions
cliRoutes ::  ClientEnv -> Dropbox (AsClientT IO)
cliRoutes :: ClientEnv -> Dropbox (AsClientT IO)
cliRoutes env :: ClientEnv
env = (forall x. ClientM x -> IO x) -> Dropbox (AsClientT IO)
forall (routes :: * -> *) (m :: * -> *) (n :: * -> *).
(HasClient m (ToServantApi routes),
 GenericServant routes (AsClientT n),
 Client n (ToServantApi routes) ~ ToServant routes (AsClientT n)) =>
(forall x. m x -> n x) -> routes (AsClientT n)
genericClientHoist
    (\x :: ClientM x
x -> ClientM x -> ClientEnv -> IO (Either ClientError x)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM x
x ClientEnv
env IO (Either ClientError x) -> (Either ClientError x -> IO x) -> IO x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ClientError -> IO x)
-> (x -> IO x) -> Either ClientError x -> IO x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> IO x
forall e a. Exception e => e -> IO a
throwIO x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return)

createClient :: IO (Dropbox (AsClientT IO))
createClient :: IO (Dropbox (AsClientT IO))
createClient = do
  BaseUrl
baseUri <- String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl "https://api.dropboxapi.com/"
  Manager
manager <- IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
  pure $ ClientEnv -> Dropbox (AsClientT IO)
cliRoutes (ClientEnv -> Dropbox (AsClientT IO))
-> ClientEnv -> Dropbox (AsClientT IO)
forall a b. (a -> b) -> a -> b
$ Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
baseUri