module Azure ( createContainer
, deleteContainer
, listContainerRaw
#ifndef NO_XML
, listContainer
#endif
, changeContainerACL
, createBlob
, deleteBlob
, getBlob
, breakLease
, module Azure.BlobDataTypes) where
import Azure.BlobDataTypes
#ifndef NO_XML
import Azure.BlobListParser
#endif
import Network.HTTP.Conduit
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
import System.Locale
import Data.List
import Data.Time
import Data.Char (isSpace)
import Data.CaseInsensitive (foldedCase)
import Data.Maybe (fromJust, isJust)
import Network (withSocketsDo)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
import Data.Monoid
import Control.Arrow (second)
import Control.Monad.IO.Class (liftIO)
import Data.Digest.Pure.SHA (hmacSha256, bytestringDigest)
import qualified Data.ByteString.Base64 as B64
maybeResponseError :: Response t -> Maybe (Int, t)
maybeResponseError rsp = let status = (responseStatus rsp) in
if statusCode status >= 300 || statusCode status < 200
then Just (statusCode status, responseBody rsp)
else Nothing
createContainer :: B.ByteString
-> B.ByteString
-> B.ByteString
-> AccessControl
-> IO (Maybe (Int, L.ByteString))
createContainer account authKey containerName accessControl = do
let resource = "/" <> containerName
rsp <- doRequest account authKey resource [("restype", "container")] "PUT" "" hdrs
return $ maybeResponseError rsp
where hdrs = case accessControl of
ContainerPublic -> [("x-ms-blob-public-access", "container")]
BlobPublic -> [("x-ms-blob-public-access", "blob")]
Private -> []
deleteContainer :: B.ByteString
-> B.ByteString
-> B.ByteString
-> IO (Maybe (Int, L.ByteString))
deleteContainer account authKey containerName = do
let resource = "/" <> containerName
rsp <- doRequest account authKey resource [("restype", "container")] "DELETE" "" []
return $ maybeResponseError rsp
listContainerRaw :: B.ByteString
-> B.ByteString
-> B.ByteString
-> IO (Either (Int, L.ByteString) L.ByteString)
listContainerRaw account authKey containerName = do
let resource = "/" <> containerName
rsp <- doRequest account authKey resource [("restype", "container"), ("comp", "list")] "GET" "" []
case maybeResponseError rsp of
Just err -> return $ Left err
Nothing -> return $ Right $ responseBody rsp
#ifndef NO_XML
listContainer :: B.ByteString
-> B.ByteString
-> B.ByteString
-> IO (Either (Int, L.ByteString) [Blob])
listContainer account authKey containerName = do
res <- listContainerRaw account authKey containerName
case res of
Right raw -> fmap Right $ parse $ L8.unpack $ raw
Left err -> return $ Left err
#endif
changeContainerACL :: B.ByteString
-> B.ByteString
-> B.ByteString
-> AccessControl
-> IO (Maybe (Int, L.ByteString))
changeContainerACL account authKey containerName accessControl = do
let resource = "/" <> containerName
rsp <- doRequest account authKey resource [("restype", "container"), ("comp", "acl")] "PUT" "" hdrs
return $ maybeResponseError rsp
where hdrs = case accessControl of
ContainerPublic -> [("x-ms-blob-public-access", "container")]
BlobPublic -> [("x-ms-blob-public-access", "blob")]
Private -> []
createBlob :: B.ByteString
-> B.ByteString
-> B.ByteString
-> BlobSettings
-> IO (Maybe (Int, L.ByteString))
createBlob account authKey containerName blobSettings =
case blobSettings of
BlockBlobSettings name contents common ->
createBlockBlob name contents common
PageBlobSettings name contentLength common ->
createPageBlob name contentLength common
where
createBlockBlob :: B.ByteString -> B.ByteString -> CommonBlobSettings -> IO (Maybe (Int, L.ByteString))
createBlockBlob name content conf = do
let resource = "/" <> containerName <> "/" <> name
rsp <- doRequest account authKey resource [] "PUT" content hdrs
return $ maybeResponseError rsp
where hdrs = map (second fromJust) $ filter (\(_,a) -> isJust a)
[ ("Content-Type", blobSettingsContentType conf)
, ("Content-Encoding", blobSettingsContentEncoding conf)
, ("Content-Language", blobSettingsContentLanguage conf)
, ("Content-MD5", blobSettingsContentMD5 conf)
, ("Cache-Control", blobSettingsCacheControl conf)
, ("x-ms-blob-type", Just "BlockBlob") ]
createPageBlob :: B.ByteString -> Integer -> CommonBlobSettings -> IO (Maybe (Int, L.ByteString))
createPageBlob name contentLength conf = do
let resource = "/" <> containerName <> "/" <> name
rsp <- doRequest account authKey resource [] "PUT" "" hdrs
return $ maybeResponseError rsp
where hdrs = map (second fromJust) $ filter (\(_,a) -> isJust a)
[ ("Content-Type", blobSettingsContentType conf)
, ("Content-Encoding", blobSettingsContentEncoding conf)
, ("Content-Language", blobSettingsContentLanguage conf)
, ("Content-MD5", blobSettingsContentMD5 conf)
, ("Cache-Control", blobSettingsCacheControl conf)
, ("x-ms-blob-type", Just "PageBlob")
, ("x-ms-blob-content-length", Just $ B8.pack $ show $ contentLength)
]
deleteBlob :: B.ByteString
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> IO (Maybe (Int, L.ByteString))
deleteBlob account authKey containerName blobName = do
let resource = "/" <> containerName <> "/" <> blobName
rsp <- doRequest account authKey resource [] "DELETE" "" []
return $ maybeResponseError rsp
getBlob :: B.ByteString
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> IO (Either (Int, L.ByteString) L.ByteString)
getBlob account authKey containerName blobName = do
let resource = "/" <> containerName <> "/" <> blobName
rsp <- doRequest account authKey resource [] "GET" "" []
return $ case maybeResponseError rsp of
Just err -> Left err
Nothing -> Right $ responseBody rsp
breakLease :: B.ByteString
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> IO (Maybe (Int, L.ByteString))
breakLease account authKey containerName blobName = do
let resource = "/" <> containerName <> "/" <> blobName
rsp <- doRequest account authKey resource [("comp", "lease")] "PUT" "" [("x-ms-lease-action", "break")]
return $ maybeResponseError rsp
doRequest :: B.ByteString -> B.ByteString -> B.ByteString -> [(B.ByteString, B.ByteString)] -> B.ByteString -> B.ByteString -> [Header] -> IO (Response L.ByteString)
doRequest account authKey resource params reqType reqBody extraHeaders = do
now <- liftIO httpTime
withSocketsDo $ withManager $ \manager -> do
initReq <- parseUrl $ B8.unpack ("http://" <> account <> ".blob.core.windows.net" <> resource <> encodeParams params)
let headers = ("x-ms-version", "2011-08-18")
: ("x-ms-date", now)
: extraHeaders ++ requestHeaders initReq
let signData = defaultSignData { verb = reqType
, contentLength = if reqType `elem` ["PUT", "DELETE"] || not (B.null reqBody) then B8.pack $ show $ B.length reqBody else ""
, canonicalizedHeaders = canonicalizeHeaders headers
, canonicalizedResource = canonicalizeResource account resource params }
let signature = sign authKey signData
let authHeader = ("Authorization", "SharedKey " <> account <> ":" <> signature)
let request = initReq { method = reqType
, requestHeaders = authHeader : headers
, checkStatus = \_ _ _ -> Nothing
, requestBody = RequestBodyBS reqBody }
httpLbs request manager
encodeParams :: [(B.ByteString, B.ByteString)] -> B.ByteString
encodeParams [] = ""
encodeParams ((k1,v1):ps) = "?" <> k1 <> "=" <> v1 <> encodeRest ps
where encodeRest = B.concat . map (\(k,v) -> "&" <> k <> "=" <> v)
canonicalizeHeaders :: [Header] -> B.ByteString
canonicalizeHeaders headers = B.intercalate "\n" unfoldHeaders
where headerStrs = map (\(a, b) -> strip $ foldedCase a <> ":" <> strip b) headers
xmsHeaders = filter (\hdr -> "x-ms" `B.isPrefixOf` hdr) headerStrs
sortedHeaders = sort xmsHeaders
unfoldHeaders = map (B8.pack . unwords . words . B8.unpack) sortedHeaders
canonicalizeResource :: B.ByteString -> B.ByteString -> [(B.ByteString, B.ByteString)] -> B.ByteString
canonicalizeResource accountName uriPath params = "/" <> accountName <> uriPath <> "\n" <> canonParams
where canonParams = strip $ B.intercalate "\n" $ map (\(k,v) -> k <> ":" <> v) $ sortBy (\(k1,_) (k2,_) -> compare k1 k2) params
strip :: B.ByteString -> B.ByteString
strip = f . f
where f = B8.pack . reverse . dropWhile isSpace . B8.unpack
data SignData = SignData { verb :: B.ByteString
, contentEncoding :: B.ByteString
, contentLanguage :: B.ByteString
, contentLength :: B.ByteString
, contentMD5 :: B.ByteString
, contentType :: B.ByteString
, date :: B.ByteString
, ifModifiedSince :: B.ByteString
, ifMatch :: B.ByteString
, ifNoneMatch :: B.ByteString
, ifUnmodifiedSince :: B.ByteString
, range :: B.ByteString
, canonicalizedHeaders :: B.ByteString
, canonicalizedResource :: B.ByteString
}
defaultSignData :: SignData
defaultSignData = SignData undefined "" "" "" "" "" "" "" "" "" "" "" undefined undefined
stringToSign :: SignData -> B.ByteString
stringToSign SignData {..} =
strip $ B.intercalate "\n" [verb, contentEncoding, contentLanguage, contentLength, contentMD5, contentType, date, ifModifiedSince, ifMatch, ifNoneMatch, ifUnmodifiedSince, range, canonicalizedHeaders, canonicalizedResource]
httpTime :: IO B.ByteString
httpTime = fmap (B8.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT") getCurrentTime
sign :: B.ByteString -> SignData -> B.ByteString
sign key = B64.encode . toStrict . bytestringDigest . hmacSha256 (toLazy $ B64.decodeLenient key) . LUTF8.fromString . B8.unpack . stringToSign
toLazy :: B8.ByteString -> LUTF8.ByteString
toLazy a = L.fromChunks [a]
toStrict :: LUTF8.ByteString -> B8.ByteString
toStrict = B.concat . L.toChunks