diff --git a/Azure.hs b/Azure.hs --- a/Azure.hs +++ b/Azure.hs @@ -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 diff --git a/Azure/BlobDataTypes.hs b/Azure/BlobDataTypes.hs --- a/Azure/BlobDataTypes.hs +++ b/Azure/BlobDataTypes.hs @@ -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 diff --git a/azurify.cabal b/azurify.cabal --- a/azurify.cabal +++ b/azurify.cabal @@ -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, diff --git a/azurify.hs b/azurify.hs --- a/azurify.hs +++ b/azurify.hs @@ -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 ()