module Dropbox (
mkConfig,
Config(..),
CertVerifier(..),
certVerifierInsecure,
certVerifierFromPemFile,
certVerifierFromRootCerts,
AppId(..),
Hosts(..),
hostsDefault,
Locale,
localeEn, localeEs, localeFr, localeDe, localeJp,
AccessType(..),
Manager,
withManager,
RequestToken(..),
authStart,
AccessToken(..),
authFinish,
Session(..),
getAccountInfo, AccountInfo(..),
getMetadata, getMetadataWithChildren, getMetadataWithChildrenIfChanged,
Meta(..), MetaBase(..), MetaExtra(..), FolderContents(..), FileExtra(..),
FolderHash(..), FileRevision(..),
getFile, getFileBs,
addFile, forceFile, updateFile,
fileRevisionToString, folderHashToString,
ErrorMessage, URL, Path,
RequestBody(..), bsRequestBody, bsSink,
) where
import Network.HTTP.Base (urlEncode)
import qualified Data.ByteString.UTF8 as UTF8 (toString, fromString)
import qualified Data.URLEncoded as URLEncoded
import qualified Network.URI as URI
import Data.URLEncoded (URLEncoded)
import qualified Text.JSON as JSON
import Text.JSON (JSON, readJSON, showJSON)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as BS8
import Data.CaseInsensitive (CI)
import Data.Word (Word64)
import Data.Int (Int64)
import Data.Time.Clock (UTCTime(utctDay), getCurrentTime)
import Data.Time.Format (parseTime, formatTime)
import System.Locale (defaultTimeLocale)
import Control.Monad (liftM)
import qualified Control.Monad.Trans.Class as MT
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Network.HTTP.Conduit as HC
import qualified Network.HTTP.Types as HT
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra as TLSExtra
import Data.Certificate.X509 (X509)
import qualified Data.Certificate.X509 as X509
import Data.Certificate.PEM as PEM
import Data.Conduit (Sink, Source, Resource)
import qualified Blaze.ByteString.Builder.ByteString as BlazeBS
import System.IO as IO
import qualified Paths_dropbox_sdk as Paths
type ErrorMessage = String
type URL = String
type Path = String
apiVersion = "1"
data AccessType
= AccessTypeDropbox
| AccessTypeAppFolder
deriving (Show, Eq)
data AppId = AppId String String deriving (Show, Eq)
data RequestToken = RequestToken String String deriving (Show, Eq)
data AccessToken = AccessToken String String deriving (Show, Eq)
accessTypePath :: AccessType -> String
accessTypePath AccessTypeDropbox = "dropbox"
accessTypePath AccessTypeAppFolder = "sandbox"
accessTypeRoot :: AccessType -> String
accessTypeRoot AccessTypeDropbox = "dropbox"
accessTypeRoot AccessTypeAppFolder = "app_folder"
data Hosts = Hosts
{ hostsWeb :: String
, hostsApi :: String
, hostsApiContent :: String
} deriving (Show, Eq)
hostsDefault :: Hosts
hostsDefault = Hosts
{ hostsWeb = "www.dropbox.com"
, hostsApi = "api.dropbox.com"
, hostsApiContent = "api-content.dropbox.com"
}
newtype Locale = Locale String deriving (Show, Eq)
localeEn :: Locale
localeEn = Locale "en"
localeEs :: Locale
localeEs = Locale "es"
localeFr :: Locale
localeFr = Locale "fr"
localeDe :: Locale
localeDe = Locale "de"
localeJp :: Locale
localeJp = Locale "jp"
data Config = Config
{ configHosts :: Hosts
, configUserLocale :: Locale
, configAppId :: AppId
, configAccessType :: AccessType
, configCertVerifier :: CertVerifier
} deriving (Show)
type CertVerifierFunc =
HT.Ascii
-> [X509]
-> IO TLS.TLSCertificateUsage
data CertVerifier = CertVerifier
{ certVerifierName :: String
, certVerifierFunc :: CertVerifierFunc
}
instance Show CertVerifier where
show (CertVerifier name _) = "CertVerifier " ++ show name
mkConfig ::
Locale
-> String
-> String
-> AccessType
-> IO Config
mkConfig userLocale appKey appSecret accessType = do
caFile <- Paths.getDataFileName "trusted-certs.crt"
vf <- do
r <- certVerifierFromPemFile caFile
case r of
Right vf -> return $ vf
Left err -> fail $ "Unable to load root certificates from " ++ (show caFile) ++ ": " ++ err
return $ Config
{ configHosts = hostsDefault
, configUserLocale = userLocale
, configAppId = AppId appKey appSecret
, configAccessType = accessType
, configCertVerifier = vf
}
data Session = Session
{ sessionConfig :: Config
, sessionAccessToken :: AccessToken
}
certVerifierInsecure :: CertVerifier
certVerifierInsecure = CertVerifier "insecure" (\_ _ -> return TLS.CertificateUsageAccept)
rightsOrFirstLeft :: [Either a b] -> Either a [b]
rightsOrFirstLeft = foldr f (Right [])
where
f (Left e) _ = Left e
f _ (Left e) = Left e
f (Right v) (Right vs) = Right (v:vs)
certVerifierFromPemFile :: FilePath -> IO (Either ErrorMessage CertVerifier)
certVerifierFromPemFile filePath = do
raw <- withFile filePath IO.ReadMode BS.hGetContents
let pems = PEM.parsePEMs raw
let es = [X509.decodeCertificate (LBS.fromChunks [stuff]) | (_, stuff) <- pems]
case rightsOrFirstLeft es of
Left err -> return $ Left err
Right x509s -> return $ Right $ CertVerifier ("PEM file: " ++ show filePath) (certVerifierFromRootCerts x509s)
certAll :: [IO TLS.TLSCertificateUsage] -> IO TLS.TLSCertificateUsage
certAll [] = return TLS.CertificateUsageAccept
certAll (head:rest) = do
r <- head
case r of
TLS.CertificateUsageAccept -> certAll rest
reject -> return $ reject
certVerifierFromRootCerts ::
[X509]
-> HT.Ascii
-> [X509]
-> IO TLS.TLSCertificateUsage
certVerifierFromRootCerts roots domain chain = do
utcTime <- getCurrentTime
let day = utctDay utcTime
certAll
[ return $ TLSExtra.certificateVerifyDomain (BS8.unpack domain) chain
, checkTrustChain day chain
]
where
checkTrustChain _ [] = return $ TLS.CertificateUsageReject $ TLS.CertificateRejectOther "empty chain"
checkTrustChain day (head:rest) = do
if isUnexpired day head
then do
issuerMatch <- mapM (head `isIssuedBy`) roots
if any (== True) issuerMatch
then return $ TLS.CertificateUsageAccept
else case rest of
[] -> return $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA
(next:_) -> do
nextOk <- TLSExtra.certificateVerifyAgainst head next
if nextOk
then checkTrustChain day rest
else return $ TLS.CertificateUsageReject $ TLS.CertificateRejectOther "break in verification chain"
else return $ TLS.CertificateUsageReject $ TLS.CertificateRejectExpired
isIssuedBy :: X509 -> X509 -> IO Bool
isIssuedBy c issuer =
if subjectDN issuer == issuerDN c
then TLSExtra.certificateVerifyAgainst c issuer
else return False
subjectDN c = X509.certSubjectDN $ X509.x509Cert c
issuerDN c = X509.certIssuerDN $ X509.x509Cert c
isUnexpired day cert =
let ((beforeDay, _, _), (afterDay, _, _)) = X509.certValidity (X509.x509Cert cert)
in beforeDay < day && day <= afterDay
buildOAuthHeaderNoToken (AppId consumerKey consumerSecret) =
"OAuth oauth_version=\"1.0\", oauth_signature_method=\"PLAINTEXT\""
++ ", oauth_consumer_key=\"" ++ urlEncode consumerKey ++ "\""
++ ", oauth_signature=\"" ++ sig ++ "\""
where
sig = urlEncode consumerSecret ++ "&"
buildOAuthHeader (AppId consumerKey consumerSecret) (signingKey, signingSecret) =
"OAuth oauth_version=\"1.0\", oauth_signature_method=\"PLAINTEXT\""
++ ", oauth_consumer_key=\"" ++ urlEncode consumerKey ++ "\""
++ ", oauth_token=\"" ++ urlEncode signingKey ++ "\""
++ ", oauth_signature=\"" ++ sig ++ "\""
where
sig = urlEncode consumerSecret ++ "&" ++ urlEncode signingSecret
authStart ::
Manager
-> Config
-> Maybe URL
-> IO (Either ErrorMessage (RequestToken, URL))
authStart mgr config callback = do
result <- httpClientGet mgr vf uri oauthHeader (mkHandler handler)
return $ mergeLefts result
where
Locale locale = configUserLocale config
host = hostsApi (configHosts config)
webHost = hostsWeb (configHosts config)
consumerPair = configAppId config
uri = "https://" ++ host ++ ":443/" ++ apiVersion ++ "/oauth/request_token?locale=" ++ urlEncode locale
oauthHeader = buildOAuthHeaderNoToken consumerPair
vf = certVerifierFunc $ configCertVerifier config
handler 200 _ body = do
let sBody = UTF8.toString body
case parseTokenParts sBody of
Left err -> Left $ "couldn't understand response from Dropbox: " ++ err
Right requestToken@(RequestToken requestTokenKey _) -> do
let authorizeUrl = "https://" ++ webHost ++ "/"++apiVersion++"/oauth/authorize?locale=" ++ urlEncode locale ++ "&oauth_token=" ++ urlEncode requestTokenKey ++ callbackSuffix
Right (requestToken, authorizeUrl)
handler code reason body = Left $ "server returned " ++ show code ++ ": " ++ show reason ++ ": " ++ show body
callbackSuffix = case callback of
Nothing -> ""
Just callbackUrl -> "&oauth_callback=" ++ urlEncode callbackUrl
parseTokenParts :: String -> Either String RequestToken
parseTokenParts s = do
enc <- URLEncoded.importString s
key <- requireKey enc "oauth_token"
secret <- requireKey enc "oauth_token_secret"
return $ RequestToken key secret
authFinish ::
Manager
-> Config
-> RequestToken
-> IO (Either ErrorMessage (AccessToken, String))
authFinish mgr config (RequestToken rtKey rtSecret) = do
result <- httpClientGet mgr vf uri oauthHeader (mkHandler handler)
return $ mergeLefts result
where
host = hostsApi (configHosts config)
(Locale locale) = configUserLocale config
consumerPair = configAppId config
uri = "https://" ++ host ++ ":443/"++apiVersion++"/oauth/access_token?locale=" ++ urlEncode locale
oauthHeader = buildOAuthHeader consumerPair (rtKey, rtSecret)
vf = certVerifierFunc $ configCertVerifier config
handler 200 _ body = do
let sBody = UTF8.toString body
case parseResponse sBody of
Left err -> Left $ "couldn't understand response from Dropbox: " ++ err
Right value -> Right value
handler code reason body = Left $ "server returned " ++ show code ++ ": " ++ show reason ++ ": " ++ show body
parseResponse :: String -> Either String (AccessToken, String)
parseResponse s = do
enc <- URLEncoded.importString s
key <- requireKey enc "oauth_token"
secret <- requireKey enc "oauth_token_secret"
userId <- requireKey enc "uid"
return $ (AccessToken key secret, userId)
requireKey :: URLEncoded -> String -> Either String String
requireKey enc name = case URLEncoded.lookup name enc of
Just value -> return value
Nothing -> Left $ "missing parameter \"" ++ name ++ "\""
dbTimeFormat = "%a, %d %b %Y %H:%M:%S %z"
dbFormatTime = formatTime defaultTimeLocale dbTimeFormat
dbParseTime = parseTime defaultTimeLocale dbTimeFormat
readJsonFieldT :: JSON a => String -> [(String, JSON.JSValue)] -> b -> (a -> b) -> JSON.Result b
readJsonFieldT a as d t = case lookup a as of
Just jv -> do
v <- readJSON jv
return (t v)
Nothing -> JSON.Ok d
readJsonFieldD :: JSON a => String -> [(String, JSON.JSValue)] -> a -> JSON.Result a
readJsonFieldD a as d = readJsonFieldT a as d id
readJsonField :: JSON a => String -> [(String, JSON.JSValue)] -> JSON.Result a
readJsonField a as = maybe (fail $ "missing field \"" ++ a ++ "\"") return (lookup a as) >>= readJSON
handleJsonBodyT :: JSON a => (a -> b) -> ByteString -> Either ErrorMessage b
handleJsonBodyT tf body = case JSON.decode $ UTF8.toString body of
JSON.Ok v -> Right (tf v)
JSON.Error err -> Left $ "couldn't parse response from Dropbox: " ++ err
handleJsonBody :: JSON a => ByteString -> Either ErrorMessage a
handleJsonBody = handleJsonBodyT id
data AccountInfo = AccountInfo
{ accountInfoUid :: Word64
, accountInfoDisplayName :: String
, accountInfoCountry :: Maybe String
, accountInfoReferralUrl :: String
, accountInfoQuota :: Quota
} deriving (Show, Eq)
data Quota = Quota
{ quotaTotal :: Word64
, quotaNormal :: Word64
, quotaShared :: Word64
} deriving (Show, Eq)
instance JSON AccountInfo where
showJSON a = JSON.makeObj
[ ("uid", showJSON $ accountInfoUid a)
, ("display_name", showJSON $ accountInfoDisplayName a)
, ("country", showJSON $ accountInfoCountry a)
, ("referral_link", showJSON $ accountInfoReferralUrl a)
, ("quota_info", showJSON $ accountInfoQuota a)
]
readJSON (JSON.JSObject obj) = do
uid <- readJsonField "uid" m
displayName <- readJsonField "display_name" m
country <- readJsonFieldT "country" m Nothing Just
referralUrl <- readJsonField "referral_link" m
quota <- readJsonField "quota_info" m
return $ AccountInfo
{ accountInfoUid = uid
, accountInfoDisplayName = displayName
, accountInfoCountry = country
, accountInfoReferralUrl = referralUrl
, accountInfoQuota = quota
}
where m = JSON.fromJSObject obj
readJSON _ = fail "expecting an object"
instance JSON Quota where
showJSON q = JSON.makeObj
[ ("quota", showJSON $ quotaTotal q)
, ("normal", showJSON $ quotaNormal q)
, ("shared", showJSON $ quotaShared q)
]
readJSON (JSON.JSObject obj) = do
total <- readJsonField "quota" m
normal <- readJsonField "normal" m
shared <- readJsonField "shared" m
return $ Quota
{ quotaTotal = total
, quotaNormal = normal
, quotaShared = shared
}
where m = JSON.fromJSObject obj
readJSON _ = fail "expecting an object"
getAccountInfo ::
Manager
-> Session
-> IO (Either ErrorMessage AccountInfo)
getAccountInfo mgr session = do
result <- doGet mgr session hostsApi "account/info" [] (mkHandler handler)
return $ mergeLefts result
where
handler 200 _ body = handleJsonBody body
handler code reason body = Left $ "non-200 response from Dropbox (" ++ (show code) ++ ":" ++ reason ++ ": " ++ (show body) ++ ")"
data Meta = Meta MetaBase MetaExtra
deriving (Eq, Show)
data MetaBase = MetaBase
{ metaRoot :: AccessType
, metaPath :: String
, metaIsDeleted :: Bool
, metaThumbnail :: Bool
, metaIcon :: String
} deriving (Eq, Show)
data MetaExtra
= File FileExtra
| Folder
deriving (Eq, Show)
newtype FileRevision = FileRevision String deriving (Eq, Show)
fileRevisionToString (FileRevision s) = s
data FileExtra = FileExtra
{ fileBytes :: Integer
, fileHumanSize :: String
, fileRevision :: FileRevision
, fileModified :: UTCTime
} deriving (Eq, Show)
newtype FolderHash = FolderHash String deriving (Eq, Show)
folderHashToString (FolderHash s) = s
data FolderContents = FolderContents
{ folderHash :: FolderHash
, folderChildren :: [Meta]
} deriving (Eq, Show)
newtype MetaWithChildren = MetaWithChildren (Meta, Maybe FolderContents)
removeMetaChildren (MetaWithChildren (meta, _)) = meta
addMetaChildren meta = MetaWithChildren (meta, Nothing)
instance JSON Meta where
showJSON = showJSON.addMetaChildren
readJSON = (liftM removeMetaChildren).readJSON
instance JSON MetaWithChildren where
showJSON (MetaWithChildren (Meta base extra, maybeContents)) = JSON.makeObj (baseFields ++ extraFields ++ contentsFields)
where
baseFields =
[ ("root", showJSON $ accessTypeRoot $ metaRoot base)
, ("path", showJSON $ metaPath base)
, ("is_deleted", showJSON $ metaIsDeleted base)
, ("thumb_exists", showJSON $ metaThumbnail base)
, ("icon", showJSON $ metaIcon base)
]
extraFields = case extra of
File f ->
[ ("bytes", showJSON $ fileBytes f)
, ("size", showJSON $ fileHumanSize f)
, ("rev", showJSON $ fileRevisionToString $ fileRevision f)
, ("modified", showJSON $ dbFormatTime $ fileModified f)
]
Folder -> []
contentsFields = case maybeContents of
Just fc ->
[ ("hash", showJSON $ folderHashToString $ folderHash fc)
, ("contents", showJSON $ map addMetaChildren (folderChildren fc))
]
Nothing -> []
readJSON (JSON.JSObject obj) = do
rootStr :: String <- readJsonField "root" m
root <- case rootStr of
"app_folder" -> return AccessTypeAppFolder
"dropbox" -> return AccessTypeDropbox
_ -> fail ("expecting \"app_folder\" or \"dropbox\", instead got: " ++ show rootStr)
path <- readJsonField "path" m
isDeleted <- readJsonFieldD "is_deleted" m False
thumbnail <- readJsonField "thumb_exists" m
icon <- readJsonField "icon" m
let base = MetaBase {
metaRoot = root
, metaPath = path
, metaIsDeleted = isDeleted
, metaThumbnail = thumbnail
, metaIcon = icon
}
isFolder <- readJsonField "is_dir" m
(extra, contents) <- if isFolder
then do
hash <- readJsonFieldD "hash" m ""
children <- readJsonFieldD "contents" m []
return $ (Folder, Just FolderContents
{ folderHash = FolderHash hash
, folderChildren = (map removeMetaChildren children)
})
else do
bytes <- readJsonField "bytes" m
humanSize <- readJsonField "size" m
revision <- readJsonField "rev" m
modifiedStr <- readJsonField "modified" m
modified <- case dbParseTime modifiedStr of
Just utcTime -> return utcTime
Nothing -> fail "invalid date/time format"
return $ (File FileExtra
{ fileBytes = bytes
, fileHumanSize = humanSize
, fileRevision = FileRevision revision
, fileModified = modified
}, Nothing)
return $ MetaWithChildren (Meta base extra, contents)
where
m = JSON.fromJSObject obj
readJSON _ = fail "expecting an object"
checkPath :: Path -> IO (Either ErrorMessage a) -> IO (Either ErrorMessage a)
checkPath ('/':_) action = action
checkPath _ _ = return $ Left $ "path must start with \"/\""
getMetadata ::
Manager
-> Session
-> Path
-> IO (Either ErrorMessage Meta)
getMetadata mgr session path = checkPath path $ do
result <- doGet mgr session hostsApi url params (mkHandler handler)
return $ mergeLefts result
where
at = accessTypePath $ configAccessType (sessionConfig session)
url = "metadata/" ++ at ++ path
params = [("list", "false")]
handler 200 _ body = handleJsonBody body
handler code reason body = Left $ "non-200 response from Dropbox (" ++ (show code) ++ ":" ++ reason ++ ": " ++ (show body) ++ ")"
getMetadataWithChildren ::
Manager
-> Session
-> Path
-> Maybe Integer
-> IO (Either ErrorMessage (Meta, Maybe FolderContents))
getMetadataWithChildren mgr session path childLimit = checkPath path $ do
result <- doGet mgr session hostsApi url params (mkHandler handler)
return $ mergeLefts result
where
at = accessTypePath $ configAccessType (sessionConfig session)
url = "metadata/" ++ at ++ path
params = [("list", "true")] ++ case childLimit of
Just l -> [("file_limit", show l)]
Nothing -> []
handler 200 _ body = handleJsonBodyT (\(MetaWithChildren v) -> v) body
handler code reason body = Left $ "non-200 response from Dropbox (" ++ (show code) ++ ":" ++ reason ++ ": " ++ (show body) ++ ")"
getMetadataWithChildrenIfChanged ::
Manager
-> Session
-> Path
-> Maybe Integer
-> FolderHash
-> IO (Either ErrorMessage (Maybe (Meta, Maybe FolderContents)))
getMetadataWithChildrenIfChanged mgr session path childLimit (FolderHash hash) = checkPath path $ do
result <- doGet mgr session hostsApi url params (mkHandler handler)
return $ mergeLefts result
where
at = accessTypePath $ configAccessType (sessionConfig session)
url = "metadata/" ++ at ++ path
params = [("list", "true"), ("hash", hash)] ++ case childLimit of
Just l -> [("file_limit", show l)]
Nothing -> []
handler 200 _ body = handleJsonBodyT (\(MetaWithChildren v) -> Just v) body
handler 304 _ _ = Right Nothing
handler code reason body = Left $ "non-200 response from Dropbox (" ++ (show code) ++ ":" ++ reason ++ ": " ++ (show body) ++ ")"
getFile ::
Manager
-> Session
-> Path
-> Maybe FileRevision
-> (Meta -> Sink ByteString IO r)
-> IO (Either ErrorMessage (Meta, r))
getFile mgr session path mrev sink = checkPath path $ do
result <- doGet mgr session hostsApiContent url params handler
return $ mergeLefts result
where
at = accessTypePath $ configAccessType (sessionConfig session)
url = "files/" ++ at ++ path
params = maybe [] (\(FileRevision rev) -> [("rev", rev)]) mrev
handler (HT.Status 200 _) headers = case getHeaders "X-Dropbox-Metadata" headers of
[metaJson] -> case handleJsonBody metaJson of
Left err -> C.Sink $ return $ C.SinkNoData (Left err)
Right meta -> do
r <- sink meta
return $ Right (meta, r)
l -> return $ Left $ "expecting response to have exactly one \"X-Dropbox-Metadata\" header, found " ++ show (length l)
handler (HT.Status code reason) _ = do
body <- bsSink
return $ Left $ "non-200 response from Dropbox (" ++ (show code) ++ ":" ++ (BS8.unpack reason) ++ ": " ++ (show body) ++ ")"
getFileBs ::
Manager
-> Session
-> Path
-> Maybe FileRevision
-> IO (Either ErrorMessage (Meta, ByteString))
getFileBs mgr session path mrev = getFile mgr session path mrev (\_ -> bsSink)
addFile ::
Manager
-> Session
-> Path
-> RequestBody
-> IO (Either ErrorMessage Meta)
addFile mgr session path contents = putFile mgr session path contents [("overwrite", "false")]
updateFile ::
Manager
-> Session
-> Path
-> RequestBody
-> FileRevision
-> IO (Either ErrorMessage Meta)
updateFile mgr session path contents (FileRevision rev) =
putFile mgr session path contents [("parent_rev", rev)]
forceFile ::
Manager
-> Session
-> Path
-> RequestBody
-> IO (Either ErrorMessage Meta)
forceFile mgr session path contents = putFile mgr session path contents [("overwrite", "true")]
putFile ::
HC.Manager
-> Session
-> Path
-> RequestBody
-> [(String,String)]
-> IO (Either ErrorMessage Meta)
putFile mgr session path contents params = checkPath path $ do
result <- doPut mgr session hostsApiContent url params contents (mkHandler handler)
return $ mergeLefts result
where
at = accessTypePath $ configAccessType (sessionConfig session)
url = "files_put/" ++ at ++ path
handler 200 _ body = handleJsonBody body
handler code reason body = Left $ "non-200 response from Dropbox (" ++ (show code) ++ ":" ++ reason ++ ": " ++ (show body) ++ ")"
generateDropboxURI' :: Bool -> String -> String -> Int -> String -> [(String, String)] -> String
generateDropboxURI' escapePath proto host port path params = URI.uriToString id (URLEncoded.addToURI (URLEncoded.importList params) (URI.URI proto (Just $ URI.URIAuth "" host $ ":" ++ show port) path' "" "")) ""
where path' = if escapePath then (URI.escapeURIString URI.isAllowedInURI path) else path
prepRequest :: Session -> (Hosts -> String) -> String -> [(String, String)] -> (String, String)
prepRequest (Session config (AccessToken atKey atSecret)) hostSelector path params = (uri, oauthHeader)
where
host = hostSelector (configHosts config)
(Locale locale) = configUserLocale config
consumerPair = configAppId config
uri = generateDropboxURI' False "https:" host 443 ("/" ++ apiVersion ++ "/" ++ path) (("locale", locale) : params)
oauthHeader = buildOAuthHeader consumerPair (atKey, atSecret)
doPut ::
Manager
-> Session
-> (Hosts -> String)
-> String
-> [(String,String)]
-> RequestBody
-> Handler r
-> IO (Either ErrorMessage r)
doPut mgr session hostSelector path params requestBody handler = do
let (uri, oauthHeader) = prepRequest session hostSelector path params
let vf = certVerifierFunc $ configCertVerifier $ sessionConfig session
httpClientPut mgr vf uri oauthHeader handler requestBody
doGet ::
Manager
-> Session
-> (Hosts -> String)
-> String
-> [(String,String)]
-> Handler r
-> IO (Either ErrorMessage r)
doGet mgr session hostSelector path params handler = do
let (uri, oauthHeader) = prepRequest session hostSelector path params
let vf = certVerifierFunc $ configCertVerifier $ sessionConfig session
httpClientGet mgr vf uri oauthHeader handler
type Manager = HC.Manager
withManager :: (Manager -> IO r) -> IO r
withManager inner = HC.withManager $ \manager ->
MT.lift $ inner manager
type SimpleHandler r = Int -> String -> ByteString -> r
type Handler r = HT.Status -> HT.ResponseHeaders -> (Sink ByteString IO r)
data RequestBody = RequestBody Int64 (Source IO ByteString)
bsRequestBody :: ByteString -> RequestBody
bsRequestBody bs = RequestBody length (CL.sourceList [bs])
where
length = fromInteger $ toInteger $ BS.length bs
getHeaders :: CI HT.Ascii -> [HT.Header] -> [HT.Ascii]
getHeaders name headers = [ val | (key, val) <- headers, key == name ]
mkHandler :: SimpleHandler r -> Handler r
mkHandler sh (HT.Status code reason) _headers = do
bs <- bsSink
return $ sh code (BS8.unpack reason) bs
mergeLefts :: Either a (Either a b) -> Either a b
mergeLefts v = case v of
Left a -> Left a
Right r -> r
bsSink :: Resource m => Sink ByteString m ByteString
bsSink = do
chunks <- CL.consume
return $ BS.concat chunks
httpClientDo ::
Manager
-> HT.Ascii
-> RequestBody
-> CertVerifierFunc
-> URL
-> String
-> Handler r
-> IO (Either String r)
httpClientDo mgr method (RequestBody len bsSource) vf url oauthHeader handler =
case HC.parseUrl url of
Just baseReq -> do
let req = baseReq {
HC.secure = True,
HC.method = method,
HC.requestHeaders = headers,
HC.requestBody = HC.RequestBodySource len builderSource,
HC.checkCerts = vf,
HC.checkStatus = \_ _ -> Nothing }
HC.Response code headers body <- C.runResourceT $ HC.http req mgr
result <- C.runResourceT (body C.$$ handler code headers)
return $ Right result
Nothing -> do
return $ Left $ "bad URL: " ++ show url
where
headers = [("Authorization", UTF8.fromString oauthHeader)]
builderSource = bsSource C.$= (CL.map BlazeBS.fromByteString)
httpClientGet :: Manager -> CertVerifierFunc -> URL -> String -> Handler r -> IO (Either String r)
httpClientGet mgr vf url oauthHeader handler = httpClientDo mgr "GET" (bsRequestBody BS.empty) vf url oauthHeader handler
httpClientPut :: Manager -> CertVerifierFunc -> URL -> String -> Handler r -> RequestBody -> IO (Either String r)
httpClientPut mgr vf url oauthHeader handler requestBody = httpClientDo mgr "PUT" requestBody vf url oauthHeader handler