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(..),
addFile, forceFile, updateFile,
fileRevisionToString, folderHashToString,
ErrorMessage, URL, Path,
RequestBody, bsRequestBody
) 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.Word (Word64)
import Data.Int (Int64)
import Data.List (isPrefixOf)
import Data.Time.Clock (UTCTime(utctDay), getCurrentTime)
import Data.Time.Format (parseTime, formatTime)
import System.Locale (defaultTimeLocale)
import Control.Monad (liftM)
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Network.HTTP.Enumerator as HE
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.Enumerator (Iteratee, Enumerator)
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"
getMetadata ::
Manager
-> Session
-> Path
-> IO (Either ErrorMessage Meta)
getMetadata mgr session path = do
if "/" `isPrefixOf` path
then do
result <- doGet mgr session hostsApi url params (mkHandler handler)
return $ mergeLefts result
else return $ Left $ "path must start with \"/\""
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 = do
if "/" `isPrefixOf` path
then do
result <- doGet mgr session hostsApi url params (mkHandler handler)
return $ mergeLefts result
else return $ Left $ "'path' must start with \"/\""
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) = do
if "/" `isPrefixOf` path
then do
result <- doGet mgr session hostsApi url params (mkHandler handler)
return $ mergeLefts result
else return $ Left $ "'path' must start with \"/\""
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) ++ ")"
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 ::
HE.Manager
-> Session
-> Path
-> RequestBody
-> IO (Either ErrorMessage Meta)
forceFile mgr session path contents = putFile mgr session path contents [("overwrite", "true")]
putFile ::
HE.Manager
-> Session
-> Path
-> RequestBody
-> [(String,String)]
-> IO (Either ErrorMessage Meta)
putFile mgr session path contents params =
if "/" `isPrefixOf` path
then do
result <- doPut mgr session hostsApiContent url params contents (mkHandler handler)
return $ mergeLefts result
else return $ Left $ "path must start with \"/\""
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 = HE.Manager
withManager :: (Manager -> IO r) -> IO r
withManager = HE.withManager
type SimpleHandler r = Int -> String -> ByteString -> r
type Handler r = HT.Status -> HT.ResponseHeaders -> (Iteratee ByteString IO r)
data RequestBody = RequestBody Int64 (forall r. Enumerator ByteString IO r)
bsRequestBody :: ByteString -> RequestBody
bsRequestBody bs = RequestBody length (E.enumLists [[bs]])
where
length = fromInteger $ toInteger $ BS.length bs
mkHandler :: SimpleHandler r -> Handler r
mkHandler sh (HT.Status code reason) _headers = do
bs <- bsIteratee
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
bsIteratee :: Monad m => Iteratee ByteString m ByteString
bsIteratee = do
chunks <- EL.consume
return $ BS.concat chunks
httpClientDo ::
Manager
-> HT.Ascii
-> RequestBody
-> CertVerifierFunc
-> URL
-> String
-> Handler r
-> IO (Either String r)
httpClientDo mgr method (RequestBody len bsEnum) vf url oauthHeader handler =
case HE.parseUrl url of
Just baseReq -> do
let req = baseReq {
HE.secure = True,
HE.method = method,
HE.requestHeaders = headers,
HE.requestBody = HE.RequestBodyEnum len builderEnum,
HE.checkCerts = vf }
resp <- E.run_ $ HE.http req handler mgr
return $ Right resp
Nothing -> do
return $ Left $ "bad URL: " ++ show url
where
headers = [("Authorization", UTF8.fromString oauthHeader)]
builderEnum = E.joinE bsEnum (EL.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