From 07eb59fda533b26d7ef740c629251ea86717c543 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Mon, 31 Oct 2016 01:10:30 -0700 Subject: [PATCH] Add Minio monad and start getService --- app/Main.hs | 14 ++--- src/Network/Minio/API.hs | 87 +++++++++++++++++++------------- src/Network/Minio/Data.hs | 61 ++++++++++++++++++---- src/Network/Minio/Data/Crypto.hs | 4 +- src/Network/Minio/Sign/V4.hs | 29 ++++++----- 5 files changed, 126 insertions(+), 69 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 48b3b3a..81b21d5 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 09f8e69..bc28692 100644 --- a/src/Network/Minio/API.hs +++ b/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 "" diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 7fce081..506a93e 100644 --- a/src/Network/Minio/Data.hs +++ b/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 diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs index a344eb1..21e2b21 100644 --- a/src/Network/Minio/Data/Crypto.hs +++ b/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)) diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 4fa0877..d3d7a7c 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/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)]