diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, yihuang + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of yihuang nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/Aliyun.hs b/Network/Aliyun.hs new file mode 100644 --- /dev/null +++ b/Network/Aliyun.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE OverloadedStrings + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , RecordWildCards + , TypeFamilies + , TupleSections + , FlexibleContexts + , Rank2Types + #-} +module Network.Aliyun + ( Yun(..) + , YunConf(..) + , YunEnv + , BucketQuery(..) + , runYun + , runYunWithManager + , listService + , putBucket + , getBucket + , getBucketContents + , getBucketContentsLifted + , getBucketACL + , deleteBucket + , putObject + , putObjectStr + , putObjectStream + , putObjectFile + , getObject + , getObjectRange + , getObjectStream + , getObjectRangeStream + , copyObject + , headObject + , deleteObject + , deleteObjects + , module Network.Aliyun.Types + ) where + +import qualified Prelude as P +import BasicPrelude +import qualified Filesystem.Path as Path +import qualified Filesystem.Path.CurrentOS as Path +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Encoding as T +import Data.Time.Clock (UTCTime(UTCTime)) + +import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Control +import Control.Monad.Base +import qualified Control.Exception.Lifted as Lifted +import qualified Blaze.ByteString.Builder as B + +import Data.Maybe (maybeToList) +import Data.Default (Default) +import Data.Time (getCurrentTime, formatTime) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as C +import qualified Data.Conduit.List as C +import Data.Aeson (FromJSON) +import Text.XML.ToJSON (parseXML) + +import qualified System.IO as IO +import System.Locale (defaultTimeLocale) +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as W + +import Network.Aliyun.Types +import Network.Aliyun.Utils + +data YunConf = YunConf + { yunHost :: !ByteString + , yunId :: !ByteString + , yunKey :: !ByteString + } + +type YunEnv = (YunConf, Manager) + +newtype Yun a = Yun { unYun :: ReaderT YunEnv (ResourceT IO) a } + deriving (Functor, Applicative, Monad, MonadIO, C.MonadResource, C.MonadThrow, C.MonadUnsafeIO) + +instance MonadBase IO Yun where + liftBase = Yun . liftBase + +instance MonadBaseControl IO Yun where + newtype StM Yun a = YunStM { unYunStM :: StM (ReaderT YunEnv (ResourceT IO)) a } + liftBaseWith f = Yun . liftBaseWith $ \runInBase -> f $ liftM YunStM . runInBase . unYun + restoreM = Yun . restoreM . unYunStM + +askConf :: Yun YunConf +askConf = fst <$> Yun ask +askManager :: Yun Manager +askManager = snd <$> Yun ask +asksConf :: (YunConf -> a) -> Yun a +asksConf f = f <$> askConf + +-- | run yun monad with a new http manager. +runYun :: YunConf -> Yun a -> IO a +runYun conf yun = withManager $ \man -> runReaderT (unYun yun) (conf, man) + +-- | run yun monad with provided http manager. +runYunWithManager :: Manager -> YunConf -> Yun a -> ResourceT IO a +runYunWithManager man conf yun = runReaderT (unYun yun) (conf, man) + +formatNow :: IO ByteString +formatNow = S.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" <$> getCurrentTime + +data RequestHints = RequestHints + { hMethod :: !ByteString + , hPath :: !ByteString + , hQuery :: !ByteString + , hHeaders :: !W.RequestHeaders + , hBody :: !(RequestBody Yun) + , hNeedMd5 :: !Bool + } + +instance Default RequestHints where + def = RequestHints "GET" "/" "" [] (RequestBodyLBS empty) False + +mkRequest :: RequestHints -> Yun (Request Yun) +mkRequest RequestHints{..} = do + conf <- askConf + time <- liftIO formatNow + let req = def { host = yunHost conf + , method = hMethod + , path = hPath + , queryString = hQuery + , requestHeaders = ("Date", time) : hHeaders + , requestBody = hBody + } + return $ authorizeRequest req (yunId conf) (yunKey conf) hNeedMd5 + +streamRequest :: RequestHints -> Yun (Response (C.ResumableSource Yun S.ByteString)) +streamRequest hints = do + req <- mkRequest hints + askManager >>= http req + +lbsRequest :: RequestHints -> Yun (Response LByteString) +lbsRequest hints = + streamRequest hints >>= lbsResponse + +xmlResponse :: (C.MonadThrow m, FromJSON a) => Response LByteString -> m a +xmlResponse = parseXML . responseBody + +-- | list all the buckets. +listService :: Yun BucketList +listService = + xmlResponse =<< lbsRequest def + +-- | create or update a bucket. +putBucket :: ByteString -> Maybe ByteString -> Yun LByteString +putBucket name macl = do + let hds = maybeToList $ ("x-oss-acl",) <$> macl + responseBody <$> + lbsRequest def{ hMethod = "PUT" + , hPath = "/"++name + , hHeaders = hds + } + +-- | bucket item query conditions. +data BucketQuery = BucketQuery + { qryPrefix :: !ByteString + , qryMaxKeys :: !Int + , qryMarker :: !(Maybe Text) + , qryDelimiter :: !(Maybe Char) + } +instance Default BucketQuery where + def = BucketQuery "" 1000 Nothing Nothing + +-- | query bucket items. +getBucket :: ByteString -> BucketQuery -> Yun Bucket +getBucket name qry = + xmlResponse =<< lbsRequest def{ hPath = "/"++name, hQuery=qs } + where + qs = S.concat + [ "prefix=", qryPrefix qry + , "&max-keys=", S.pack $ P.show (qryMaxKeys qry) + , maybe "" (("&marker="++) . T.encodeUtf8) (qryMarker qry) + , maybe "" (("&delimiter="++) . S.singleton) (qryDelimiter qry) + ] + +-- | Generic version of `getBucketContents'. +getBucketContentsLifted :: Monad m => (forall a. Yun a -> m a) -> ByteString -> ByteString -> C.Source m BucketContent +getBucketContentsLifted liftYun name prefix = loop def{qryDelimiter=Just '/', qryPrefix=prefix} + where + withFilePath f = either id id . Path.toText . f . Path.fromText + + loop qry = do + bucket <- lift $ liftYun $ getBucket name qry + -- yield directories + mapM_ ( C.yield + . flip ContentDirectory (UTCTime (toEnum 60000) 0) + . withFilePath Path.dirname + ) + (bucketDirectories bucket) + -- yield files + mapM_ ( C.yield + . ContentFile + . (\f -> f{fileKey = withFilePath Path.filename (fileKey f)}) + ) + (bucketContents bucket) + when (bucketIsTruncated bucket) $ + loop qry{qryMarker=bucketNextMarker bucket} + +-- | get bucket items streamlined, support more then 1000 items. +getBucketContents :: ByteString -> ByteString -> C.Source Yun BucketContent +getBucketContents = getBucketContentsLifted id + +-- | query bucket acl info. +getBucketACL :: ByteString -> Yun BucketACL +getBucketACL name = + xmlResponse =<< lbsRequest def{ hPath = S.concat ["/", name, "?acl"] } + +-- | delete bucket by name +deleteBucket :: ByteString -> Yun LByteString +deleteBucket name = + responseBody <$> + lbsRequest def{ hMethod = "DELETE" + , hPath = "/"++name + } + +-- | upload a file. +putObject :: ByteString -> ByteString -> RequestBody Yun -> Yun LByteString +putObject bucket name body = + responseBody <$> + lbsRequest def{ hMethod = "PUT" + , hPath = S.concat ["/", bucket, "/", name] + , hBody = body + } + +-- | Upload a file with `LByteString' content. +putObjectStr :: ByteString -> ByteString -> LByteString -> Yun LByteString +putObjectStr bucket name body = putObject bucket name (RequestBodyLBS body) + +-- | Upload a file from disk streamlined. +putObjectFile :: ByteString -> ByteString -> IO.FilePath -> Yun LByteString +putObjectFile bucket name path = + Lifted.bracket + (liftIO $ IO.openBinaryFile path IO.ReadMode) + (liftIO . IO.hClose) + (\h -> do + size <- fromIntegral <$> liftIO (IO.hFileSize h) + let src = C.sourceHandle h C.$= C.map B.fromByteString + putObjectStream bucket name size src + ) + +-- | Upload a file from a source streamlined. +-- aliyun don't support chunked tranfer-encoding, so size must be passed. +putObjectStream :: ByteString -> ByteString -> Int64 -> C.Source Yun B.Builder -> Yun LByteString +putObjectStream bucket name size source = + putObject bucket name (RequestBodySource size source) + +-- TODO put object multipart + +-- | download a file. +getObject :: ByteString -> ByteString -> Yun LByteString +getObject bucket name = getObjectRange bucket name Nothing + +-- | download a file streamlined. +getObjectStream :: ByteString -> ByteString -> Yun (C.ResumableSource Yun S.ByteString) +getObjectStream bucket name = getObjectRangeStream bucket name Nothing + +-- | download a range of file. +getObjectRange :: ByteString -> ByteString -> Maybe ByteString -> Yun LByteString +getObjectRange bucket name mrange = do + let hds = maybeToList $ ("Range",) . ("bytes="++) <$> mrange + responseBody <$> + lbsRequest def{ hPath = S.concat ["/", bucket, "/", name] + , hHeaders = hds + } + +-- | download a range of file streamlined. +getObjectRangeStream :: ByteString -> ByteString -> Maybe ByteString -> Yun (C.ResumableSource Yun S.ByteString) +getObjectRangeStream bucket name mrange = do + let hds = maybeToList $ ("Range",) . ("bytes="++) <$> mrange + responseBody <$> + streamRequest def{ hPath = S.concat ["/", bucket, "/", name] + , hHeaders = hds + } + +-- | copy an object. +copyObject :: ByteString -> ByteString -> ByteString -> Yun CopyResult +copyObject bucket name source = + xmlResponse =<< + lbsRequest def{ hMethod = "PUT" + , hPath = S.concat ["/", bucket, "/", name] + , hHeaders = [("x-oss-copy-source", source)] + } + +-- | HEAD request get object. +headObject :: ByteString -> ByteString -> Yun LByteString +headObject bucket name = + responseBody <$> + lbsRequest def{ hMethod = "HEAD" + , hPath = S.concat ["/", bucket, "/", name] + } + +-- | delete object. +deleteObject :: ByteString -> ByteString -> Yun LByteString +deleteObject bucket name = + responseBody <$> + lbsRequest def{ hMethod = "DELETE" + , hPath = S.concat ["/", bucket, "/", name] + } + +-- | batch delete multiple objects. +deleteObjects :: ByteString -> [ByteString] -> Bool -> Yun DeleteResult +deleteObjects bucket names verbose = do + let body = L.fromChunks $ + [ "" + , if verbose then "false" else "true" + , "" + ] ++ + concat [["", name, ""] | name <- names] ++ + [ "" ] + xmlResponse =<< + lbsRequest def{ hMethod = "POST" + , hPath = S.concat ["/", bucket, "?delete"] + , hBody = RequestBodyLBS body + , hNeedMd5 = True + } diff --git a/Network/Aliyun/Types.hs b/Network/Aliyun/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Aliyun/Types.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Aliyun.Types + ( Owner(..) + , BucketList(..) + , BucketFile(..) + , Bucket(..) + , BucketContent(..) + , BucketACL(..) + , DeleteResult(..) + , CopyResult(..) + ) where + +import qualified Prelude as P +import BasicPrelude +import Safe (readMay) +import Control.Applicative ((<|>)) + +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Aeson.Types (typeMismatch, Parser) +import Data.Aeson (FromJSON(parseJSON), Value(..), (.:), (.:?)) +import Data.Time.Clock (UTCTime(UTCTime)) +import Data.Time.Format (parseTime) +import System.Locale (defaultTimeLocale) + +data Owner = Owner + { ownerId :: !Text + , ownerName :: !Text + } deriving (Show) + +instance FromJSON Owner where + parseJSON (Object o) = + Owner <$> o .: "ID" <*> o .: "DisplayName" + parseJSON o = + typeMismatch "Object" o + +data BucketList = BucketList + { bucketOwner :: !Owner + , bucketList :: ![(Text, UTCTime)] + } deriving (Show) + +instance FromJSON BucketList where + parseJSON (Object o) = do + root <- o .: "ListAllMyBucketsResult" + let getBuckets = root .: "Buckets" >>= (.: "Bucket") + BucketList <$> (root .: "Owner" >>= parseJSON) + <*> ( (getBuckets >>= pList pBucket) + <|> pure [] + ) + where + pBucket (Object a) = + (,) <$> a .: "Name" + <*> (pTime <$> a .: "CreationDate") + pBucket a = typeMismatch "Object [BucketList.bucketList[i]]" a + parseJSON a = typeMismatch "BucketList" a + +data BucketFile = BucketFile + { fileKey :: !Text + , fileLastModified :: !UTCTime + , fileETag :: !Text + , fileType :: !Text + , fileSize :: !Integer -- to support very large file + , fileStorage :: !Text + , fileOwner :: !Owner + } deriving (Show) + +instance FromJSON BucketFile where + parseJSON (Object o) = + BucketFile <$> o .: "Key" + <*> (pTime <$> o .: "LastModified") + <*> o .: "ETag" + <*> o .: "Type" + <*> (o .: "Size" >>= strRead (readMay . T.unpack)) + <*> o .: "StorageClass" + <*> o .: "Owner" + parseJSON a = typeMismatch "Object" a + +data Bucket = Bucket + { bucketName :: !Text + , bucketPrefix :: !Text + , bucketMarker :: !Text + , bucketMaxKeys :: !Int + , bucketDelimiter :: !Text + , bucketIsTruncated :: !Bool + , bucketNextMarker :: !(Maybe Text) + , bucketContents :: ![BucketFile] + , bucketDirectories :: ![Text] + } deriving (Show) + +instance FromJSON Bucket where + parseJSON (Object o) = do + r <- o .: "ListBucketResult" + let getCommonPrefixes = r .: "CommonPrefixes" >>= (.: "Prefix") + Bucket <$> r .: "Name" + <*> r .: "Prefix" + <*> r .: "Marker" + <*> (r .: "MaxKeys" >>= strRead (readMay . T.unpack)) + <*> r .: "Delimiter" + <*> (r .: "IsTruncated" >>= strBool) + <*> r .:? "NextMarker" + <*> ( (r .: "Contents" >>= pList parseJSON) + <|> pure [] + ) + <*> ( (getCommonPrefixes >>= pList parseJSON) + <|> pure [] + ) + parseJSON a = typeMismatch "Object" a + +data BucketContent = ContentFile !BucketFile + | ContentDirectory !Text !UTCTime + deriving (Show) + +data BucketACL = BucketACL + { bucketACLOwner :: !Owner + , bucketACLs :: ![Text] + } deriving (Show) + +instance FromJSON BucketACL where + parseJSON (Object o) = do + r <- o .: "AccessControlPolicy" + let getAcls = r .: "AccessControlList" >>= (.: "Grant") + BucketACL <$> (r .: "Owner" >>= parseJSON) + <*> ( (getAcls >>= pList parseJSON) + <|> pure [] + ) + parseJSON a = typeMismatch "Object" a + +newtype DeleteResult = DeleteResult [Text] + deriving (Show) + +instance FromJSON DeleteResult where + parseJSON (Object a) = do + r <- a .: "DeleteResult" + DeleteResult <$> ( (r .: "Deleted" >>= pList pKey) + <|> pure [] + ) + where + pKey (Object o) = o .: "Key" + pKey o = typeMismatch "Object" o + parseJSON o = typeMismatch "Object" o + +data CopyResult = CopyResult + { copyLastModified :: !UTCTime + , copyETag :: !Text + } deriving (Show) + +instance FromJSON CopyResult where + parseJSON (Object o) = do + r <- o .: "CopyObjectResult" + CopyResult <$> (pTime <$> r .: "LastModified") + <*> r .: "ETag" + parseJSON o = typeMismatch "Object" o + +-- parser utils + +strRead :: (FromJSON a) => (Text -> Maybe a) -> Value -> Parser a +strRead conv o = case o of + String s -> + maybe (fail $ "convert failed:"++T.unpack s) + pure + (conv s) + _ -> parseJSON o + +strBool :: Value -> Parser Bool +strBool = strRead conv + where + conv "true" = Just True + conv "false" = Just False + conv _ = Nothing + +pList :: (Value -> Parser a) -> Value -> Parser [a] +pList p (Array a) = mapM p (V.toList a) +pList p a = (:[]) <$> p a + +pTime :: String -> UTCTime +pTime s = fromMaybe (UTCTime (toEnum 0) 0) $ parseTime defaultTimeLocale "%FT%T.000Z" s + diff --git a/Network/Aliyun/Utils.hs b/Network/Aliyun/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/Aliyun/Utils.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Aliyun.Utils where + +import qualified Prelude +import BasicPrelude + +import qualified Data.ByteString as B +import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as L +import Data.HMAC (hmac_sha1) +import qualified Data.Digest.MD5 as MD5 + +import qualified Network.HTTP.Types as W +import Network.HTTP.Conduit + +canonicalizeHeaders :: W.RequestHeaders -> ByteString +canonicalizeHeaders hds = + let hds' = [hd | hd <- hds, "x-oss-" `S.isPrefixOf` CI.foldedCase (fst hd)] + + -- merge grouped headers. + merge :: [W.Header] -> W.Header + merge [] = error "impossible [canonicalizeHeaders]" + merge xs@((name, _):_) = (name, S.concat . intersperse "," $ map snd xs) + + hds'' = map merge . group . sortBy (comparing fst) $ hds' + in S.concat [S.concat [CI.foldedCase k, ":", v, "\n"] | (k,v) <- hds''] + +bodyContent :: RequestBody m -> LByteString +bodyContent (RequestBodyLBS s) = s +bodyContent _ = error "unimplemented [bodyContent]" + +authorizeRequest :: Request m -> ByteString -> ByteString -> Bool -> Request m +authorizeRequest req identity key needMD5 = + let date = fromMaybe "" $ lookup "Date" hds + ctype = fromMaybe "" $ lookup "Content-Type" hds + bodyMD5 = B64.encode . B.pack . MD5.hash . L.unpack . bodyContent . requestBody $ req + hds' = requestHeaders req + hds = if needMD5 then ("Content-MD5", bodyMD5) : hds' else hds' + s = S.concat [ method req, "\n" + , if needMD5 then bodyMD5 else "", "\n" + , ctype, "\n" + , date, "\n", canonicalizeHeaders hds + , path req + ] + auth = S.concat [ "OSS ", identity, ":" + , B64.encode $ B.pack (hmac_sha1 (B.unpack key) (B.unpack s)) + ] + in req { requestHeaders = ("Authorization", auth) : hds } diff --git a/README.rst b/README.rst new file mode 100644 --- /dev/null +++ b/README.rst @@ -0,0 +1,10 @@ +Streamlined aliyun OSS api in Haskell. + +Features +======== + +* Support persistent http connection. + +* Support streamlined file uploading and downloading, using constant memory. + +* Support streamlined listing of bucket contents with more then 1000 items. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-aliyun.cabal b/haskell-aliyun.cabal new file mode 100644 --- /dev/null +++ b/haskell-aliyun.cabal @@ -0,0 +1,65 @@ +-- Initial haskell-aliyun.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: haskell-aliyun + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: haskell client of aliyun service. + +-- A longer description of the package. +description: See git page (https://github.com/yihuang/haskell-aliyun/) + +-- URL for the project homepage or repository. +homepage: https://github.com/yihuang/haskell-aliyun/ + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: yihuang + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: yi.codeplayer@gmail.com + +-- A copyright notice. +-- copyright: + +category: Network + +build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + +Extra-Source-Files: README.rst + , test.hs + +source-repository head + type: git + location: git://github.com/yihuang/haskell-aliyun + +library + ghc-options: -Wall -O2 + -- Modules exported by the library. + exposed-modules: Network.Aliyun + , Network.Aliyun.Types + , Network.Aliyun.Utils + + -- Modules included in this library but not exported. + -- other-modules: + + -- Other library packages from which modules are imported. + build-depends: base ==4.*, bytestring >=0.9, conduit >=0.5, http-conduit >=1.5, http-types >=0.7, transformers >=0.2, monad-control >=0.3, transformers-base >=0.4, time >=1.4, old-locale >=1.0, Crypto >=4.2, data-default >=0.5, resourcet >=0.3, basic-prelude >=0.2, base64-bytestring >=0.1, case-insensitive >=0.4, blaze-builder >= 0.3, lifted-base >= 0.1, xml2json >= 0.2, aeson >= 0.6, vector >= 0.9, text >= 0.11, safe >= 0.3, system-filepath >= 0.4 diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} +import qualified Prelude +import BasicPrelude +import Network.Aliyun +import Data.Default (def) +import qualified Data.Text.Encoding as T +import Data.ByteString.Lazy.Char8 () +import qualified Data.Conduit as C +import qualified Data.Conduit.List as C + +{- + - Before run test.hs, create a file named "config" in current directory, + - which contains two lines, the first line is identity, second line is secret key. + -} + +loadConf :: FilePath -> IO YunConf +loadConf path = do + (ident : key : _) <- lines <$> readFile path + return $ YunConf "storage.aliyun.com" (T.encodeUtf8 ident) (T.encodeUtf8 key) + +p :: (MonadIO m, Show a) => m a -> m () +p m = m >>= liftIO . putStrLn . show + +main :: IO () +main = do + conf <- loadConf "./config" + runYun conf $ do + --liftIO $ putStrLn "put stream object test4" + --p $ putObjectStream "yihuang_bucket" "test4" (C.sourceList ["hello", "world"] C.$= C.map B.fromByteString) + + liftIO $ putStrLn "list service" + p listService + liftIO $ putStrLn "put bucket" + p $ putBucket "yihuang_bucket" Nothing + liftIO $ putStrLn "list service" + p listService + liftIO $ putStrLn "get bucket" + p $ getBucket "yihuang_bucket" def + liftIO $ putStrLn "get bucket acl" + p $ getBucketACL "yihuang_bucket" + liftIO $ putStrLn "put bucket acl" + p $ putBucket "yihuang_bucket" (Just "public-read-write") + liftIO $ putStrLn "get bucket acl" + p $ getBucketACL "yihuang_bucket" + liftIO $ putStrLn "put string object test1" + p $ putObjectStr "yihuang_bucket" "test1" "hello world" + liftIO $ putStrLn "put file object test2" + p $ putObjectFile "yihuang_bucket" "test2" "./data" + liftIO $ putStrLn "get bucket" + p $ getBucket "yihuang_bucket" def + p $ getBucket "yihuang_bucket" def{qryMaxKeys=1} + p $ getBucketContents "yihuang_bucket" def{qryMaxKeys=1} C.$$ C.consume + liftIO $ putStrLn "get object test1" + p $ getObject "yihuang_bucket" "test1" + liftIO $ putStrLn "get object test2" + p $ getObject "yihuang_bucket" "test2" + liftIO $ putStrLn "get object range test2" + p $ getObjectRange "yihuang_bucket" "test2" (Just "6-11") + liftIO $ putStrLn "copy object test3" + p $ copyObject "yihuang_bucket" "test3" "/yihuang_bucket/test2" + liftIO $ putStrLn "head object test3" + p $ headObject "yihuang_bucket" "test3" + liftIO $ putStrLn "delete object test3" + p $ deleteObject "yihuang_bucket" "test3" + liftIO $ putStrLn "delete multiple objects test1 test2" + p $ deleteObjects "yihuang_bucket" ["test1", "test2"] True