Implement getService and getLocation

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

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

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

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 {

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