Add Minio monad and start getService

app/Main.hs

@@ -1,19 +1,13 @@
 module Main where
 
-import qualified Network.HTTP.Types as HT
-import qualified Network.HTTP.Conduit as NC
+-- import qualified Network.HTTP.Conduit as NC
 
 import Protolude
 
 import Network.Minio.API
-import Network.Minio.Data
 
 main :: IO ()
 main = do
-  resp <- minioExecute mc req
-  print $ NC.responseStatus resp
-  print $ NC.responseHeaders resp
-  print $ NC.responseBody resp
-  where
-    mc = MinioClient "localhost" 9000 "abcd1" "abcd1234" False "us-east-1"
-    req = RequestInfo HT.methodGet Nothing Nothing [] [] "" ""
+  mc <- connect defaultConnectInfo
+  res <- runMinio mc $ getService
+  print res

src/Network/Minio/API.hs

@@ -1,12 +1,16 @@
 module Network.Minio.API
   (
-    minioExecute
+    connect
+  , defaultConnectInfo
+  , RequestInfo(..)
+  , runMinio
+  , getService
   ) where
 
-import           Network.HTTP.Client (defaultManagerSettings)
 import qualified Network.HTTP.Types as HT
 import           Network.HTTP.Conduit (Response)
 import qualified Network.HTTP.Conduit as NC
+import           Network.HTTP.Types (Method, Header, Query)
 
 import           Lib.Prelude
 
@@ -14,37 +18,52 @@ import           Network.Minio.Data
 import           Network.Minio.Data.Crypto
 import           Network.Minio.Sign.V4
 
-runRequestDebug r mgr = do
-  print $ "runRequestDebug"
-  print $ NC.method r
-  print $ NC.secure r
-  print $ NC.host r
-  print $ NC.port r
-  print $ NC.path r
-  print $ NC.queryString r
-  print $ NC.requestHeaders r
-  -- print $ NC.requestBody r
-  NC.httpLbs r mgr
+-- runRequestDebug r mgr = do
+--   print $ "runRequestDebug"
+--   print $ NC.method r
+--   print $ NC.secure r
+--   print $ NC.host r
+--   print $ NC.port r
+--   print $ NC.path r
+--   print $ NC.queryString r
+--   print $ NC.requestHeaders r
+--   -- print $ NC.requestBody r
+--   NC.httpLbs r mgr
 
-minioExecute :: MinioClient -> RequestInfo -> IO (Response LByteString)
-minioExecute mc ri = do
-  mgr <- NC.newManager defaultManagerSettings
-  finalHeaders <- signV4 mc updatedRI
-  runRequestDebug (req finalHeaders) mgr
-  where
-    req h = NC.defaultRequest {
-        NC.method         = method ri
-      , NC.secure         = mcIsSecure mc
-      , NC.host           = encodeUtf8 $ mcEndPointHost mc
-      , NC.port           = mcEndPointPort mc
-      , NC.path           = getPathFromRI ri
-      , NC.queryString    = HT.renderQuery False $ queryParams ri
-      , NC.requestHeaders = h
-      , NC.requestBody    = NC.RequestBodyBS (payload ri)
-      }
+mkSRequest :: RequestInfo -> Minio (Response LByteString)
+mkSRequest ri = do
+  let PayloadSingle pload = payload ri
+      phash = hashSHA256 pload
+      newRI = ri {
+          payloadHash = phash
+        , headers = ("x-amz-content-sha256", phash) : (headers ri)
+        }
 
-    phash = hashSHA256 $ payload ri
-    updatedRI = 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
+
+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 (Response LByteString)
+getService = mkSRequest $
+  requestInfo HT.methodGet Nothing Nothing [] [] $
+  PayloadSingle ""

src/Network/Minio/Data.hs

@@ -1,36 +1,52 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Network.Minio.Data
   (
-    MinioClient(..)
+    ConnectInfo(..)
   , RequestInfo(..)
+  , MinioConn(..)
   , Bucket
   , Object
   , getPathFromRI
+  , Minio
+  , runMinio
+  , defaultConnectInfo
+  , connect
+  , Payload(..)
   ) where
 
 import qualified Data.ByteString as B
+import           Network.HTTP.Client (defaultManagerSettings)
 import           Network.HTTP.Types (Method, Header, Query)
+import qualified Network.HTTP.Conduit as NC
 
 import           Lib.Prelude
 
-data MinioClient = MinioClient {
-    mcEndPointHost :: Text
-  , mcEndPointPort :: Int
-  , mcAccessKey :: Text
-  , mcSecretKey :: Text
-  , mcIsSecure :: Bool
-  , mcRegion :: Text
+data ConnectInfo = ConnectInfo {
+    connectHost :: Text
+  , connectPort :: Int
+  , connectAccessKey :: Text
+  , connectSecretKey :: Text
+  , connectIsSecure :: Bool
+  , connectRegion :: Text
   } deriving (Eq, Show)
 
+defaultConnectInfo :: ConnectInfo
+defaultConnectInfo =
+  ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1"
+
 type Bucket = ByteString
 type Object = Text
 
+data Payload = PayloadSingle ByteString
+  deriving (Show, Eq)
+
 data RequestInfo = RequestInfo {
     method :: Method
   , bucket :: Maybe Bucket
   , object :: Maybe Object
   , queryParams :: Query
   , headers :: [Header]
-  , payload :: ByteString
+  , payload :: Payload
   , payloadHash :: ByteString
   }
 
@@ -39,3 +55,30 @@ getPathFromRI ri = B.concat $ parts
   where
     objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ object ri
     parts = maybe ["/"] (\b -> "/" : b : objPart) $ bucket ri
+
+data MinioErr = MErrMsg ByteString
+  deriving (Show)
+
+newtype Minio a = Minio {
+  unMinio :: ReaderT MinioConn (ExceptT MinioErr IO) a
+  } deriving (
+      Functor
+    , Applicative
+    , Monad
+    , MonadIO
+    , MonadReader MinioConn
+    )
+
+-- MinioConn holds connection info and a connection pool
+data MinioConn = MinioConn {
+    mcConnInfo :: ConnectInfo
+  , mcConnManager :: NC.Manager
+  }
+
+connect :: ConnectInfo -> IO MinioConn
+connect ci = do
+  mgr <- NC.newManager defaultManagerSettings
+  return $ MinioConn ci mgr
+
+runMinio :: MinioConn -> Minio a -> IO (Either MinioErr a)
+runMinio conn = runExceptT . flip runReaderT conn . unMinio

src/Network/Minio/Data/Crypto.hs

@@ -7,8 +7,8 @@ module Network.Minio.Data.Crypto
   , digestToBase16
   ) where
 
-import Crypto.Hash (SHA256(..), hashWith, Digest)
-import Crypto.MAC.HMAC (hmac, HMAC(hmacGetDigest))
+import Crypto.Hash (SHA256(..), hashWith)
+import Crypto.MAC.HMAC (hmac, HMAC)
 import Data.ByteArray (ByteArrayAccess, convert)
 import Data.ByteArray.Encoding (convertToBase, Base(Base16))
 

src/Network/Minio/Sign/V4.hs

@@ -6,6 +6,7 @@ module Network.Minio.Sign.V4
   , getHeadersToSign
   , getCanonicalRequest
   , SignV4Data(..)
+  , debugPrintSignV4Data
   ) where
 
 import qualified Data.ByteString as B
@@ -64,34 +65,34 @@ debugPrintSignV4Data (SignV4Data t s cr h2s ih oh sts sk) = do
 -- request path, headers, query params and payload hash, generates an
 -- updated set of headers, including the x-amz-date header and the
 -- Authorization header, which includes the signature.
-signV4 :: MinioClient -> RequestInfo
+signV4 :: ConnectInfo -> RequestInfo
        -> IO [Header]
-signV4 mc ri = do
+signV4 ci ri = do
   timestamp <- Time.getCurrentTime
-  let signData = signV4AtTime timestamp mc ri
-  debugPrintSignV4Data signData
+  let signData = signV4AtTime timestamp ci ri
+  -- debugPrintSignV4Data signData
   return $ sv4OutputHeaders signData
 
 -- | Takes a timestamp, server params and request params and generates
 -- an updated list of headers.
-signV4AtTime :: UTCTime -> MinioClient -> RequestInfo -> SignV4Data
-signV4AtTime ts mc ri =
+signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> SignV4Data
+signV4AtTime ts ci ri =
   SignV4Data ts scope canonicalRequest headersToSign (headers ri) outHeaders stringToSign signingKey
   where
     outHeaders = authHeader : headersWithDate
     timeBS = awsTimeFormatBS ts
     dateHeader = (mk "X-Amz-Date", timeBS)
-    hostHeader = (mk "host", encodeUtf8 $ mcEndPointHost mc)
+    hostHeader = (mk "host", encodeUtf8 $ connectHost ci)
 
     headersWithDate = dateHeader : hostHeader : (headers ri)
 
     authHeader = (mk "Authorization", authHeaderValue)
 
-    scope = getScope ts mc
+    scope = getScope ts ci
 
     authHeaderValue = B.concat [
       "AWS4-HMAC-SHA256 Credential=",
-      encodeUtf8 (mcAccessKey mc), "/", scope,
+      encodeUtf8 (connectAccessKey ci), "/", scope,
       ", SignedHeaders=", signedHeaders,
       ", Signature=", signature
       ]
@@ -104,9 +105,9 @@ signV4AtTime ts mc ri =
 
     signingKey = hmacSHA256RawBS "aws4_request"
                . hmacSHA256RawBS "s3"
-               . hmacSHA256RawBS (encodeUtf8 $ mcRegion mc)
+               . hmacSHA256RawBS (encodeUtf8 $ connectRegion ci)
                . hmacSHA256RawBS (awsDateFormatBS ts)
-               $ (B.concat ["AWS4", encodeUtf8 $ mcSecretKey mc])
+               $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci])
 
     stringToSign  = B.intercalate "\n" $
       ["AWS4-HMAC-SHA256",
@@ -118,10 +119,10 @@ signV4AtTime ts mc ri =
     canonicalRequest = getCanonicalRequest ri headersToSign
 
 
-getScope :: UTCTime -> MinioClient -> ByteString
-getScope ts mc = B.intercalate "/" $ [
+getScope :: UTCTime -> ConnectInfo -> ByteString
+getScope ts ci = B.intercalate "/" $ [
   pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
-  "us-east-1", "s3", "aws4_request"
+  encodeUtf8 $ connectRegion ci, "s3", "aws4_request"
   ]
 
 getHeadersToSign :: [Header] -> [(ByteString, ByteString)]