diff --git a/app/Main.hs b/app/Main.hs index e303f48..dd6ead2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,24 +8,30 @@ import Network.Minio.Data import Network.Minio.API import Control.Monad.Trans.Resource (runResourceT) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL -import qualified Network.HTTP.Conduit as NC +-- import qualified Data.Conduit as C +-- import qualified Data.Conduit.List as CL +-- import qualified Network.HTTP.Conduit as NC main :: IO () main = do mc <- connect defaultConnectInfo t <- runResourceT $ runMinio mc $ do res <- getService - liftIO $ print $ NC.responseStatus res - liftIO $ print $ NC.responseHeaders res + print res + -- case res of + -- Left e -> print e + -- Right res1 -> mapM_ print res1 + -- liftIO $ print $ NC.responseStatus res + -- liftIO $ print $ NC.responseHeaders res -- liftIO print $ NC.responseHeaders <$> res -- let bodyE = NC.responseBody <$> res -- case bodyE of -- Left x -> print x -- Right body -> body C.$$+- CL.mapM_ putStrLn -- body <- NC.responseBody <$> res - NC.responseBody res C.$$+- CL.mapM_ putStrLn + -- NC.responseBody res C.$$+- CL.mapM_ putStrLn + res <- getLocation "test1" + print res - print "Hello" + print "After runResourceT" print t diff --git a/minio-hs.cabal b/minio-hs.cabal index 9c760a2..8449f24 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -22,6 +22,7 @@ library , Network.Minio.Data.Time , Network.Minio.Sign.V4 , Network.Minio.API + , Network.Minio.XmlParser other-modules: Lib.Prelude build-depends: base >= 4.7 && < 5 , protolude >= 0.1.6 && < 0.2 @@ -30,6 +31,7 @@ library , conduit , containers , cryptonite + , errors , http-client , http-conduit , http-types @@ -39,6 +41,7 @@ library , time , transformers , transformers-base + , xml-conduit default-language: Haskell2010 default-extensions: FlexibleContexts , FlexibleInstances diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 555ea67..c652467 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -5,6 +5,7 @@ module Network.Minio.API , RequestInfo(..) , runMinio , getService + , getLocation ) where import qualified Network.HTTP.Types as HT @@ -12,8 +13,6 @@ import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import Network.HTTP.Types (Method, Header, Query) -import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) - import Lib.Prelude import qualified Data.Conduit as C @@ -21,6 +20,7 @@ import qualified Data.Conduit as C import Network.Minio.Data import Network.Minio.Data.Crypto import Network.Minio.Sign.V4 +import Network.Minio.XmlParser -- runRequestDebug r mgr = do -- print $ "runRequestDebug" @@ -34,6 +34,34 @@ import Network.Minio.Sign.V4 -- -- print $ NC.requestBody r -- NC.httpLbs r mgr +executeRequest :: RequestInfo -> Minio (Response LByteString) +executeRequest ri = do + let PayloadSingle pload = payload ri + phash = hashSHA256 pload + newRI = ri { + payloadHash = phash + , headers = ("x-amz-content-sha256", phash) : (headers ri) + } + + ci <- asks mcConnInfo + + reqHeaders <- liftIO $ signV4 ci newRI + + mgr <- asks mcConnManager + + let req = NC.defaultRequest { + NC.method = method newRI + , NC.secure = connectIsSecure ci + , NC.host = encodeUtf8 $ connectHost ci + , NC.port = connectPort ci + , NC.path = getPathFromRI ri + , NC.queryString = HT.renderQuery False $ queryParams ri + , NC.requestHeaders = reqHeaders + , NC.requestBody = NC.RequestBodyBS pload + } + + NC.httpLbs req mgr + mkSRequest :: RequestInfo -> Minio (Response (C.ResumableSource Minio ByteString)) mkSRequest ri = do let PayloadSingle pload = payload ri @@ -60,15 +88,23 @@ mkSRequest ri = do , NC.requestBody = NC.RequestBodyBS pload } - response <- NC.http req mgr - return response + NC.http req mgr requestInfo :: Method -> Maybe Bucket -> Maybe Object -> Query -> [Header] -> Payload -> RequestInfo requestInfo m b o q h p = RequestInfo m b o q h p "" --- getService :: Minio _ -- ResponseInfo -getService = mkSRequest $ - requestInfo HT.methodGet Nothing Nothing [] [] $ - PayloadSingle "" +getService :: Minio [BucketInfo] +getService = do + resp <- executeRequest $ + requestInfo HT.methodGet Nothing Nothing [] [] $ + PayloadSingle "" + parseListBuckets $ NC.responseBody resp + +getLocation :: Bucket -> Minio Text +getLocation bucket = do + resp <- executeRequest $ + requestInfo HT.methodGet (Just bucket) Nothing [("location", Nothing)] [] + (PayloadSingle "") + parseLocation $ NC.responseBody resp diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index e72c307..7f561a2 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -1,14 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.Minio.Data - ( - ConnectInfo(..) + ( ConnectInfo(..) , RequestInfo(..) -- , ResponseInfo(..) , MinioConn(..) , Bucket , Object + , BucketInfo(..) , getPathFromRI , Minio + , MinioErr(..) , runMinio , defaultConnectInfo , connect @@ -40,9 +41,15 @@ defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" -type Bucket = ByteString +type Bucket = Text type Object = Text +data BucketInfo = BucketInfo { + biName :: Bucket + , biCreationDate :: UTCTime + } deriving (Show, Eq) + + data Payload = PayloadSingle ByteString deriving (Show, Eq) @@ -61,10 +68,11 @@ getPathFromRI :: RequestInfo -> ByteString getPathFromRI ri = B.concat $ parts where objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ object ri - parts = maybe ["/"] (\b -> "/" : b : objPart) $ bucket ri + parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ bucket ri data MinioErr = MErrMsg ByteString | MErrHttp HttpException + | MErrXml ByteString deriving (Show) newtype Minio a = Minio { diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs new file mode 100644 index 0000000..14fdcf8 --- /dev/null +++ b/src/Network/Minio/XmlParser.hs @@ -0,0 +1,37 @@ +module Network.Minio.XmlParser + ( parseListBuckets + , parseLocation + ) where + +import Text.XML +import Text.XML.Cursor +import qualified Data.Text as T +import Data.Time +import Control.Error + +import Lib.Prelude + +import Network.Minio.Data + +s3Name :: Text -> Name +s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing + +s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" + +parseListBuckets :: (MonadError MinioErr m) => LByteString -> m [BucketInfo] +parseListBuckets xmldata = do + doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata + let cursor = fromDocument doc + names = cursor $// element (s3Name "Bucket") &// + element (s3Name "Name") &/ content + timeStrings = cursor $// element (s3Name "Bucket") &// + element (s3Name "CreationDate") &/ content + times <- either (throwError . MErrXml) return $ + mapM (parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack) + timeStrings + return $ map (\(n, t) -> BucketInfo n t) $ zip names times + +parseLocation :: (MonadError MinioErr m) => LByteString -> m Text +parseLocation xmldata = do + doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata + return $ T.concat $ fromDocument doc $/ content