diff --git a/Azure.hs b/Azure.hs --- a/Azure.hs +++ b/Azure.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} {-| Azurify is an incomplete yet sort-of-functional library and command line client to access the Azure Blob Storage API @@ -19,7 +19,9 @@ -} module Azure ( createContainer , deleteContainer +#ifndef NO_XML , listContainer +#endif , changeContainerACL , createBlob , deleteBlob @@ -28,23 +30,21 @@ , module Azure.BlobDataTypes) where import Azure.BlobDataTypes +#ifndef NO_XML import Azure.BlobListParser +#endif import Network.HTTP.Conduit -import Network.HTTP.Date import Network.HTTP.Types.Header import Network.HTTP.Types.Status import System.Locale import Data.List import Data.Time -import Data.Time.Clock.POSIX import Data.Char (isSpace) import Data.CaseInsensitive (foldedCase) import Data.Maybe (fromJust, isJust) import Network (withSocketsDo) -import Data.Conduit - import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L @@ -89,6 +89,7 @@ rsp <- doRequest account authKey resource [("restype", "container")] "DELETE" "" [] return $ maybeResponseError rsp +#ifndef NO_XML -- |List all blobs in a given container listContainer :: B.ByteString -- ^ The account name -> B.ByteString -- ^ Authorisation key @@ -102,6 +103,7 @@ Nothing -> do blobs <- parse $ L8.unpack $ responseBody rsp return $ Right blobs +#endif -- |Set the access control on a container changeContainerACL :: B.ByteString -- ^ The account name @@ -125,37 +127,39 @@ -> BlobSettings -- ^ The blob itself, note that Page blobs are *not supported* -> IO (Maybe (Int, L.ByteString)) -- ^ Nothing when successful, HTTP error code and content otherwise createBlob account authKey containerName blobSettings = - case blobSettingsType blobSettings of - BlockBlob -> createBlockBlob account authKey containerName blobSettings - PageBlob -> error "Page blob not implemented yet" - -createBlockBlob :: B.ByteString -> B.ByteString -> B.ByteString -> BlobSettings -> IO (Maybe (Int, L.ByteString)) -createBlockBlob account authKey containerName blobSettings = do - let resource = "/" +++ containerName +++ "/" +++ blobSettingsName blobSettings - rsp <- doRequest account authKey resource [] "PUT" (fromJust $ blobSettingsContents blobSettings) hdrs - return $ maybeResponseError rsp - where hdrs = map (second fromJust) $ filter (\(_,a) -> isJust a) - [ ("Content-Type", blobSettingsContentType blobSettings) - , ("Content-Encoding", blobSettingsContentEncoding blobSettings) - , ("Content-Language", blobSettingsContentLanguage blobSettings) - , ("Content-MD5", blobSettingsContentMD5 blobSettings) - , ("Cache-Control", blobSettingsCacheControl blobSettings) - , ("x-ms-blob-type", Just "BlockBlob") ] + 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 -> B.ByteString -> B.ByteString -> BlobSettings -> IO (Maybe (Int, L.ByteString)) -createPageBlob account authKey containerName blobSettings = do - let resource = "/" +++ containerName +++ "/" +++ blobSettingsName blobSettings - rsp <- doRequest account authKey resource [] "PUT" "" hdrs - return $ maybeResponseError rsp - where hdrs = map (second fromJust) $ filter (\(_,a) -> isJust a) - [ ("Content-Type", blobSettingsContentType blobSettings) - , ("Content-Encoding", blobSettingsContentEncoding blobSettings) - , ("Content-Language", blobSettingsContentLanguage blobSettings) - , ("Content-MD5", blobSettingsContentMD5 blobSettings) - , ("Cache-Control", blobSettingsCacheControl blobSettings) - , ("x-ms-blob-type", Just "PageBlob") - , ("x-ms-blob-content-length", Just $ B8.pack $ show $ B.length $ fromJust $ blobSettingsContents blobSettings) - ] + 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) + ] -- |Delete a blob from a container deleteBlob :: B.ByteString -- ^ The account name diff --git a/Azure/BlobDataTypes.hs b/Azure/BlobDataTypes.hs --- a/Azure/BlobDataTypes.hs +++ b/Azure/BlobDataTypes.hs @@ -1,24 +1,36 @@ module Azure.BlobDataTypes where import qualified Data.ByteString as B +import Data.Text (Text) +import Data.Default data AccessControl = ContainerPublic -- ^ the container can be enumerated and all blobs can be read by anonymous users | BlobPublic -- ^ blobs can be read by anonymous users, but the container cannot be enumerated | Private -- ^ blobs can't be read by anonymous users and the container cannot be enumerated -data BlobType = PageBlob | BlockBlob deriving (Show) +data CommonBlobSettings = BlobSettings { + blobSettingsContentType :: Maybe B.ByteString + , blobSettingsContentEncoding :: Maybe B.ByteString + , blobSettingsContentLanguage :: Maybe B.ByteString + , blobSettingsContentMD5 :: Maybe B.ByteString + , blobSettingsCacheControl :: Maybe B.ByteString + , blobSettingsMetaData :: [(Text, Text)] + } -data BlobSettings = BlobSettings { blobSettingsName :: B.ByteString - , blobSettingsContentType :: Maybe B.ByteString - , blobSettingsContentEncoding :: Maybe B.ByteString - , blobSettingsContentLanguage :: Maybe B.ByteString - , blobSettingsContentMD5 :: Maybe B.ByteString - , blobSettingsCacheControl :: Maybe B.ByteString - , blobSettingsType :: BlobType - , blobSettingsContentLength :: Maybe Integer -- ^ only for page blobs, set to Nothing for block blob - , blobSettingsContents :: Maybe B.ByteString -- ^ only for block blobs, set to Empty for page blob - } +instance Default CommonBlobSettings where + def = BlobSettings Nothing Nothing Nothing Nothing Nothing [] +data BlobSettings = + BlockBlobSettings { blockBlobName :: B.ByteString + , blockBlobContents :: B.ByteString + , blockBlobSettings :: CommonBlobSettings + } + | PageBlobSettings { pageBlobName :: B.ByteString + , pageBlobContentLength :: Integer + , pageBlobSettings :: CommonBlobSettings + } + +data BlobType = PageBlob | BlockBlob deriving (Show) data Blob = Blob { blobName :: B.ByteString , blobUrl :: B.ByteString , blobLastModified :: B.ByteString diff --git a/Azure/BlobListParser.hs b/Azure/BlobListParser.hs --- a/Azure/BlobListParser.hs +++ b/Azure/BlobListParser.hs @@ -4,10 +4,10 @@ import Azure.BlobDataTypes -import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Text.XML.HXT.Core hiding (Blob) +parse :: String -> IO [Blob] parse xml = runX (readString [] xml >>> getBlobs >>> xmlBlob) getBlobs :: (ArrowXml a) => a XmlTree XmlTree diff --git a/azurify.cabal b/azurify.cabal --- a/azurify.cabal +++ b/azurify.cabal @@ -1,5 +1,5 @@ name: azurify -version: 0.1.0.0 +version: 0.2.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 @@ -13,10 +13,39 @@ extra-source-files: Azure/BlobDataTypes.hs, Azure/BlobListParser.hs, readme.md -Library - Exposed-Modules: Azure +Flag no-hxt + Description: no xml parsing, and no hxt dependency + Default: False + +Flag library-only + Description: don't build the executable + Default: False + +library + ghc-options: -Wall + + if flag(no-hxt) + cpp-options: -DNO_XML + + extensions: + OverloadedStrings + CPP + + exposed-modules: + Azure + + if flag(no-hxt) + other-modules: + Azure.BlobDataTypes + else + other-modules: + Azure.BlobDataTypes + Azure.BlobListParser + build-depends: - base >= 4.5, + base >= 4.5 && < 5, + text, + data-default, bytestring >= 0.9.2.1, http-conduit >= 1.5.0.3, http-types >= 0.7.0, @@ -25,20 +54,28 @@ network >= 2.3.0.13, http-date >= 0.0.2, time >= 1.4, - old-locale >= 1.0.0.4, SHA >= 1.5.1, base64-bytestring >= 0.1.2.0, case-insensitive >= 0.4.0.1, utf8-string >= 0.3.7, - hxt >= 9.2.2, - cmdargs >= 0.10, - directory >= 1.1.0.2 + old-locale >= 1.0.0.4 + if !flag(no-hxt) + build-depends: + hxt >= 9.2.2 + executable azurify + if flag(library-only) + Buildable: False + + if flag(no-hxt) + cpp-options: -DNO_XML + main-is: azurify.hs - hs-source-dirs: . Azure/ build-depends: - base >= 4.5 && < 5, + base >= 4.5, + text, + data-default, bytestring >= 0.9.2.1, http-conduit >= 1.5.0.3, http-types >= 0.7.0, @@ -52,6 +89,9 @@ base64-bytestring >= 0.1.2.0, case-insensitive >= 0.4.0.1, utf8-string >= 0.3.7, - hxt >= 9.2.2, cmdargs >= 0.10, directory >= 1.1.0.2 + + if !flag(no-hxt) + build-depends: + hxt >= 9.2.2 diff --git a/azurify.hs b/azurify.hs --- a/azurify.hs +++ b/azurify.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, CPP, DeriveDataTypeable #-} module Main where @@ -69,21 +69,33 @@ , breakLeaseBlobName = def &= typ "blobname" &= argPos 2 } +#ifndef NO_XML listContainer = ListContainer { listContainerStorageName = def &= typ "accountname" &= argPos 0 , listContainerContainerName = def &= typ "containername" &= argPos 1 } &= 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 } &= 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" } &= help "Delete the container and all the blobs inside it" +#endif -mode = cmdArgsMode $ modes [uploadBlob, downloadBlob, deleteBlob, breakBlobLease, listContainer, createContainer, deleteContainer] &= help "Access the Azure blob storage" &= program "azurify" &= summary "Azurify v1.0" +mode = cmdArgsMode $ modes [uploadBlob, downloadBlob, deleteBlob, breakBlobLease +#ifndef NO_XML + , listContainer +#endif + , createContainer +#ifndef NO_XML + , deleteContainer +#endif + ] &= help "Access the Azure blob storage" &= program "azurify" &= summary "Azurify v1.0" main :: IO () main = do @@ -93,18 +105,15 @@ case m of UploadBlob path account container name contType contEnc contLang contCache -> do contents <- B.readFile path - res <- Az.createBlob (B8.pack account) - azureKey (B8.pack container) - (Az.BlobSettings (B8.pack name) - (B8.pack `fmap` contType) - (B8.pack `fmap` contEnc) - (B8.pack `fmap` contLang) - Nothing - (B8.pack `fmap` contCache) - Az.BlockBlob - Nothing - (Just contents) - ) + res <- Az.createBlob (B8.pack account) azureKey (B8.pack container) $ + Az.BlockBlobSettings (B8.pack name) contents $ + Az.BlobSettings + (B8.pack `fmap` contType) + (B8.pack `fmap` contEnc) + (B8.pack `fmap` contLang) + Nothing + (B8.pack `fmap` contCache) + [] case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Nothing -> return () @@ -126,11 +135,13 @@ 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) 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 let acl = case access of { Just "blobpublic" -> Az.BlobPublic; @@ -143,6 +154,7 @@ case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Nothing -> return () +#ifndef NO_XML DeleteContainer account container force -> do if force == (Just True) then do res <- Az.listContainer (B8.pack account) azureKey (B8.pack container) @@ -154,5 +166,4 @@ case res of Just (stat, err) -> putStrLn "error" >> print stat >> putStrLn "\n" >> print err Nothing -> return () - - +#endif