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 Network.HTTP.Base (urlEncodeVars, urlDecode)
import System.Locale
import System.IO (openBinaryFile, IOMode(..))
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
default (Int)
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 settings ->
blockBlobApi name contents settings []
PageBlobSettings name contentLength settings ->
createPageBlob name contentLength settings
FileBlobSettings name fp settings -> do
h <- openBinaryFile fp ReadMode
let doBlock i = do
contents <- B.hGetSome h (4 * 1048576)
if B.null contents then return $ Right (i 1)
else do
mrsp <- createBlockBlob name settings contents (toB64 i)
case mrsp of
Nothing -> doBlock (i + 1)
Just rsp -> return $ Left rsp
result <- doBlock 1
case result of
Left err -> return $ Just err
Right lastBlockId -> do
putStrLn $ show lastBlockId ++ " blocks uploaded. Committing..."
createBlobApi [] name (blockListBody lastBlockId) settings [("comp", "blocklist")]
where
toB64 = B64.encode . B8.pack . padZeroes . show
padZeroes s | length s > maxSize = error "azurify: too big for this hack!"
| otherwise = concatMap (const "0") [1 .. maxSize length s] ++ s
where maxSize = 5
blockListBody :: Int -> B.ByteString
blockListBody lastId = "<?xml version=\"1.0\" encoding=\"utf-8\"?><BlockList>"
<> commits lastId
<> "</BlockList>"
commits :: Int -> B.ByteString
commits 0 = ""
commits i = commits (i 1) <> "<Uncommitted>" <> toB64 i <> "</Uncommitted>"
createBlockBlob name settings contents blockId =
blockBlobApi name contents settings [
("comp", "block"), ("blockid", blockId)
]
blockBlobApi = createBlobApi [("x-ms-blob-type", "BlockBlob")]
createBlobApi :: [Header]
-> B.ByteString -> B.ByteString -> CommonBlobSettings
-> [(B.ByteString, B.ByteString)]
-> IO (Maybe (Int, L.ByteString))
createBlobApi headers name content conf params = do
let resource = "/" <> containerName <> "/" <> name
rsp <- doRequest account authKey resource params "PUT" content hdrs
return $ maybeResponseError rsp
where
hdrs = blobHeaders conf headers
blobHeaders conf extra = (
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)
]
) ++ extra
createPageBlob :: B.ByteString -> Integer -> CommonBlobSettings -> IO (Maybe (Int, L.ByteString))
createPageBlob name contentLength conf = createBlobApi
[ ("x-ms-blob-type", "PageBlob")
, ("x-ms-blob-content-length", B8.pack $ show $ contentLength)
] name "" conf []
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
let url = B8.unpack ("http://" <> account <> ".blob.core.windows.net" <> resource <> encodeParams params)
initReq <- parseUrl url
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 vars = ("?" <>) $ B8.pack $ urlEncodeVars $ map (\(a,b) -> (B8.unpack a, B8.unpack b)) vars
liftToString :: (String -> String) -> B8.ByteString -> B8.ByteString
liftToString f = B8.pack . f . B8.unpack
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) -> liftToString urlDecode k <> ":" <> liftToString urlDecode 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