azurify 0.2.0.0 → 0.3.0.0
raw patch · 4 files changed
+81/−50 lines, 4 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Azure: listContainerRaw :: ByteString -> ByteString -> ByteString -> IO (Either (Int, ByteString) ByteString)
Files
- Azure.hs +40/−28
- Azure/BlobDataTypes.hs +2/−1
- azurify.cabal +9/−3
- azurify.hs +30/−18
Azure.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings, CPP #-}- {-| Azurify is an incomplete yet sort-of-functional library and command line client to access the Azure Blob Storage API @@ -19,6 +17,7 @@ -} module Azure ( createContainer , deleteContainer+ , listContainerRaw #ifndef NO_XML , listContainer #endif@@ -51,14 +50,14 @@ 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 -(+++) = B.append-+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)@@ -71,7 +70,7 @@ -> AccessControl -- ^ Access control of the container -> IO (Maybe (Int, L.ByteString)) -- ^ Nothing when creating was successful, otherwise HTTP status and content createContainer account authKey containerName accessControl = do- let resource = "/" +++ containerName+ let resource = "/" <> containerName rsp <- doRequest account authKey resource [("restype", "container")] "PUT" "" hdrs return $ maybeResponseError rsp where hdrs = case accessControl of@@ -85,10 +84,22 @@ -> B.ByteString -- ^ Container name -> IO (Maybe (Int, L.ByteString)) -- ^ Nothing when creating was successful, otherwise HTTP status and content deleteContainer account authKey containerName = do- let resource = "/" +++ containerName+ let resource = "/" <> containerName rsp <- doRequest account authKey resource [("restype", "container")] "DELETE" "" [] return $ maybeResponseError rsp +-- |List all blobs in a given container+listContainerRaw :: B.ByteString -- ^ The account name+ -> B.ByteString -- ^ Authorisation key+ -> B.ByteString -- ^ Container name+ -> IO (Either (Int, L.ByteString) L.ByteString) -- ^ Either the HTTP error code and content OR a list of Blobs+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 -- |List all blobs in a given container listContainer :: B.ByteString -- ^ The account name@@ -96,13 +107,10 @@ -> B.ByteString -- ^ Container name -> IO (Either (Int, L.ByteString) [Blob]) -- ^ Either the HTTP error code and content OR a list of Blobs listContainer 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 -> do- blobs <- parse $ L8.unpack $ responseBody rsp- return $ Right blobs+ res <- listContainerRaw account authKey containerName+ case res of+ Right raw -> fmap Right $ parse $ L8.unpack $ raw+ Left err -> return $ Left err #endif -- |Set the access control on a container@@ -112,7 +120,7 @@ -> AccessControl -- ^ Access control specifier -> IO (Maybe (Int, L.ByteString)) -- ^ Nothing when successful, HTTP error code and content otherwise changeContainerACL account authKey containerName accessControl = do- let resource = "/" +++ containerName+ let resource = "/" <> containerName rsp <- doRequest account authKey resource [("restype", "container"), ("comp", "acl")] "PUT" "" hdrs return $ maybeResponseError rsp where hdrs = case accessControl of@@ -135,7 +143,7 @@ where createBlockBlob :: B.ByteString -> B.ByteString -> CommonBlobSettings -> IO (Maybe (Int, L.ByteString)) createBlockBlob name content conf = do- let resource = "/" +++ containerName +++ "/" +++ name+ let resource = "/" <> containerName <> "/" <> name rsp <- doRequest account authKey resource [] "PUT" content hdrs return $ maybeResponseError rsp where hdrs = map (second fromJust) $ filter (\(_,a) -> isJust a)@@ -148,7 +156,7 @@ createPageBlob :: B.ByteString -> Integer -> CommonBlobSettings -> IO (Maybe (Int, L.ByteString)) createPageBlob name contentLength conf = do- let resource = "/" +++ containerName +++ "/" +++ name+ let resource = "/" <> containerName <> "/" <> name rsp <- doRequest account authKey resource [] "PUT" "" hdrs return $ maybeResponseError rsp where hdrs = map (second fromJust) $ filter (\(_,a) -> isJust a)@@ -168,7 +176,7 @@ -> B.ByteString -- ^ The blob name -> IO (Maybe (Int, L.ByteString)) -- ^ Nothing when successful, HTTP error code and content otherwise deleteBlob account authKey containerName blobName = do- let resource = "/" +++ containerName +++ "/" +++ blobName+ let resource = "/" <> containerName <> "/" <> blobName rsp <- doRequest account authKey resource [] "DELETE" "" [] -- TODO: Add support for snapshots return $ maybeResponseError rsp @@ -179,7 +187,7 @@ -> B.ByteString -- ^ The blob name -> IO (Either (Int, L.ByteString) L.ByteString) -- ^ Nothing when successful, HTTP error code and content otherwise getBlob account authKey containerName blobName = do- let resource = "/" +++ containerName +++ "/" +++ blobName+ let resource = "/" <> containerName <> "/" <> blobName rsp <- doRequest account authKey resource [] "GET" "" [] return $ case maybeResponseError rsp of Just err -> Left err@@ -192,7 +200,7 @@ -> B.ByteString -- ^ The blob name -> IO (Maybe (Int, L.ByteString)) -- ^ Nothing when successful, HTTP error code and content otherwise breakLease account authKey containerName blobName = do- let resource = "/" +++ containerName +++ "/" +++ blobName+ let resource = "/" <> containerName <> "/" <> blobName rsp <- doRequest account authKey resource [("comp", "lease")] "PUT" "" [("x-ms-lease-action", "break")] return $ maybeResponseError rsp @@ -200,7 +208,7 @@ 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)+ 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@@ -209,7 +217,7 @@ , canonicalizedHeaders = canonicalizeHeaders headers , canonicalizedResource = canonicalizeResource account resource params } let signature = sign authKey signData- let authHeader = ("Authorization", "SharedKey " +++ account +++ ":" +++ signature)+ let authHeader = ("Authorization", "SharedKey " <> account <> ":" <> signature) let request = initReq { method = reqType , requestHeaders = authHeader : headers , checkStatus = \_ _ _ -> Nothing -- don't throw an exception when a non-2xx error code is received@@ -218,19 +226,19 @@ encodeParams :: [(B.ByteString, B.ByteString)] -> B.ByteString encodeParams [] = ""-encodeParams ((k,v):ps) = "?" +++ k +++ "=" +++ v +++ encodeRest ps- where encodeRest = B.concat . map (\(k,v) -> "&" +++ k +++ "=" +++ v)+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+ 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,v1) (k2,v2) -> compare k1 k2) params+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@@ -252,11 +260,12 @@ , canonicalizedResource :: B.ByteString } +defaultSignData :: SignData defaultSignData = SignData undefined "" "" "" "" "" "" "" "" "" "" "" undefined undefined stringToSign :: SignData -> B.ByteString-stringToSign (SignData verb ce clan clen cmd5 ct date ifMod ifMatch ifNMatch ifUnmod range canonHeaders canonResource) =- strip $ B.intercalate "\n" [verb, ce, clan, clen, cmd5, ct, date, ifMod, ifMatch, ifNMatch, ifUnmod, range, canonHeaders, canonResource]+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@@ -264,5 +273,8 @@ 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
Azure/BlobDataTypes.hs view
@@ -15,7 +15,7 @@ , blobSettingsContentMD5 :: Maybe B.ByteString , blobSettingsCacheControl :: Maybe B.ByteString , blobSettingsMetaData :: [(Text, Text)]- }+ } deriving Show instance Default CommonBlobSettings where def = BlobSettings Nothing Nothing Nothing Nothing Nothing []@@ -29,6 +29,7 @@ , pageBlobContentLength :: Integer , pageBlobSettings :: CommonBlobSettings }+ deriving Show data BlobType = PageBlob | BlockBlob deriving (Show) data Blob = Blob { blobName :: B.ByteString
azurify.cabal view
@@ -1,8 +1,8 @@ name: azurify-version: 0.2.0.0+version: 0.3.0.0 synopsis: A simple library for accessing Azure blob storage description: An interface for a few basic functions of the Microsoft Azure blob storage. Creating and deleting containers as well as uploading, downloading and breaking leases of blobs is supported.-homepage: http://arnovanlumig.com/azurify.html+homepage: http://arnovanlumig.com/azure license: BSD3 license-file: LICENSE author: Arno van Lumig@@ -30,6 +30,7 @@ extensions: OverloadedStrings CPP+ RecordWildCards exposed-modules: Azure@@ -71,9 +72,14 @@ if flag(no-hxt) cpp-options: -DNO_XML + extensions:+ OverloadedStrings+ CPP+ RecordWildCards+ main-is: azurify.hs build-depends:- base >= 4.5,+ base >= 4.5 && < 5, text, data-default, bytestring >= 0.9.2.1,
azurify.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} module Main where @@ -18,29 +18,36 @@ , uploadBlobContentEncoding :: Maybe String , uploadBlobContentLanguage :: Maybe String , uploadBlobContentCache :: Maybe String+ , accessKey :: String } | DeleteBlob { deleteBlobStorageName :: String , deleteBlobContainerName :: String , deleteBlobBlobName :: String+ , accessKey :: String } | DownloadBlob { downloadBlobStorageName :: String , downloadBlobContainerName :: String , downloadBlobBlobName :: String+ , accessKey :: String } | CreateContainer { createContainerStorageName :: String , createContainerContainerName :: String , createContainerACL :: Maybe String+ , accessKey :: String } | DeleteContainer { deleteContainerStorageName :: String , deleteContainerContainerName :: String , deleteContainerForce :: Maybe Bool+ , accessKey :: String } | ListContainer { listContainerStorageName :: String , listContainerContainerName :: String+ , accessKey :: String } | BreakBlobLease { breakLeaseStorageName :: String , breakLeaseContainerName :: String , breakLeaseBlobName :: String+ , accessKey :: String } deriving (Show, Data, Typeable, Eq) @@ -52,38 +59,45 @@ , uploadBlobContentEncoding = def &= name "contentencoding" , uploadBlobContentLanguage = def &= name "contentlanguage" , uploadBlobContentCache = def &= name "cachecontrol"+ , accessKey = def &= name "accesskey" } &= help "Upload a blob" downloadBlob = DownloadBlob { downloadBlobStorageName = def &= typ "accountname" &= argPos 0 , downloadBlobContainerName = def &= typ "containername" &= argPos 1 , downloadBlobBlobName = def &= typ "blobname" &= argPos 2+ , accessKey = def &= name "accesskey" } &= help "Download a blob" deleteBlob = DeleteBlob { deleteBlobStorageName = def &= typ "accountname" &= argPos 0 , deleteBlobContainerName = def &= typ "containername" &= argPos 1 , deleteBlobBlobName = def &= typ "blobname" &= argPos 2+ , accessKey = def &= name "accesskey" } &= help "Delete a blob" breakBlobLease = BreakBlobLease { breakLeaseStorageName = def &= typ "accountname" &= argPos 0 , breakLeaseContainerName = def &= typ "containername" &= argPos 1 , breakLeaseBlobName = def &= typ "blobname" &= argPos 2+ , accessKey = def &= name "accesskey" } #ifndef NO_XML listContainer = ListContainer { listContainerStorageName = def &= typ "accountname" &= argPos 0 , listContainerContainerName = def &= typ "containername" &= argPos 1+ , accessKey = def &= name "accesskey" } &= help "List all blobs in a container" #endif createContainer = CreateContainer { createContainerStorageName = def &= typ "accountname" &= argPos 0 , createContainerContainerName = def &= typ "containername" &= argPos 1 , createContainerACL = def &= typ "blobpublic|containerpublic|private" &= argPos 2+ , accessKey = def &= name "accesskey" } &= help "Create a container with the specified access control" #ifndef NO_XML deleteContainer = DeleteContainer { deleteContainerStorageName = def &= typ "accountname" &= argPos 0 , deleteContainerContainerName = def &= typ "containername" &= argPos 1 , deleteContainerForce = def &= name "force"+ , accessKey = def &= name "accesskey" } &= help "Delete the container and all the blobs inside it" #endif @@ -100,12 +114,10 @@ main :: IO () main = do m <- cmdArgsRun mode- putStrLn "Please enter your authkey:"- azureKey <- B.getLine case m of- UploadBlob path account container name contType contEnc contLang contCache -> do+ UploadBlob path account container name contType contEnc contLang contCache azureKey -> do contents <- B.readFile path- res <- Az.createBlob (B8.pack account) azureKey (B8.pack container) $+ res <- Az.createBlob (B8.pack account) (B8.pack azureKey) (B8.pack container) $ Az.BlockBlobSettings (B8.pack name) contents $ Az.BlobSettings (B8.pack `fmap` contType)@@ -117,32 +129,32 @@ case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Nothing -> return ()- DownloadBlob account container blobname -> do -- TODO: progress indicator+ DownloadBlob account container blobname azureKey -> do -- TODO: progress indicator pwd <- getCurrentDirectory- res <- Az.getBlob (B8.pack account) azureKey (B8.pack container) (B8.pack blobname)+ res <- Az.getBlob (B8.pack account) (B8.pack azureKey) (B8.pack container) (B8.pack blobname) let path = pwd ++ "/" ++ blobname putStrLn path case res of Left (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Right content -> L.writeFile path content- DeleteBlob account container blobname -> do- res <- Az.deleteBlob (B8.pack account) azureKey (B8.pack container) (B8.pack blobname)+ DeleteBlob account container blobname azureKey -> do+ res <- Az.deleteBlob (B8.pack account) (B8.pack azureKey) (B8.pack container) (B8.pack blobname) case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err _ -> return ()- BreakBlobLease account container blobname -> do- res <- Az.breakLease (B8.pack account) azureKey (B8.pack container) (B8.pack blobname)+ BreakBlobLease account container blobname azureKey -> do+ res <- Az.breakLease (B8.pack account) (B8.pack azureKey) (B8.pack container) (B8.pack blobname) case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err _ -> return () #ifndef NO_XML- ListContainer account container -> do -- TODO: output formatting- res <- Az.listContainer (B8.pack account) azureKey (B8.pack container)+ ListContainer account container azureKey -> do -- TODO: output formatting+ res <- Az.listContainer (B8.pack account) (B8.pack azureKey) (B8.pack container) case res of Left (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Right blobs -> mapM_ print blobs #endif- CreateContainer account container access -> do+ CreateContainer account container access azureKey -> do let acl = case access of { Just "blobpublic" -> Az.BlobPublic; Just "containerpublic" -> Az.ContainerPublic;@@ -150,19 +162,19 @@ Nothing -> Az.Private; _ -> error "invalid access control specified"; }- res <- Az.createContainer (B8.pack account) azureKey (B8.pack container) acl+ res <- Az.createContainer (B8.pack account) (B8.pack azureKey) (B8.pack container) acl case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Nothing -> return () #ifndef NO_XML- DeleteContainer account container force -> do+ DeleteContainer account container force azureKey -> do if force == (Just True) then do- res <- Az.listContainer (B8.pack account) azureKey (B8.pack container)+ res <- Az.listContainer (B8.pack account) (B8.pack azureKey) (B8.pack container) case res of Left (stat, err) -> putStrLn "error listing container" >> print stat >> putStrLn "\n" >> print err Right (x:_) -> error "Container not empty, use --force to ignore" else do- res <- Az.deleteContainer (B8.pack account) azureKey (B8.pack container)+ res <- Az.deleteContainer (B8.pack account) (B8.pack azureKey) (B8.pack container) case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Nothing -> return ()