From a45ef309e0669f0d5eff2982ba8617091a2e47ee Mon Sep 17 00:00:00 2001 From: Tobias Florek Date: Mon, 15 Jun 2015 10:33:54 +0200 Subject: [PATCH] port to cryptonite --- oauthenticated.cabal | 7 +++--- src/Network/OAuth.hs | 6 ++--- src/Network/OAuth/Signing.hs | 13 +++++----- src/Network/OAuth/Simple.hs | 16 ++++++------ src/Network/OAuth/ThreeLegged.hs | 41 +++++++++++++++---------------- src/Network/OAuth/Types/Params.hs | 15 ++++++++--- 6 files changed, 52 insertions(+), 46 deletions(-) diff --git a/oauthenticated.cabal b/oauthenticated.cabal index 01efb14..c6eb92f 100644 --- a/oauthenticated.cabal +++ b/oauthenticated.cabal @@ -1,5 +1,5 @@ name: oauthenticated -version: 0.1.3.4 +version: 0.2.0 synopsis: Simple OAuth for http-client description: @@ -57,16 +57,15 @@ library Network.OAuth.Util build-depends: base >= 4.6 && < 4.9 , aeson >= 0.6.2 && < 0.10 - , base64-bytestring >= 1.0 && < 1.1 , blaze-builder >= 0.3 , bytestring >= 0.9 , case-insensitive >= 1.0 && < 1.3 - , crypto-random >= 0.0.7 - , cryptohash >= 0.11 && < 0.12 + , cryptonite == 0.2.* , either >= 4.0 && < 5.0 , exceptions >= 0.4 , http-client >= 0.2.0 , http-types >= 0.8 + , memory >= 0.7 , mtl >= 2.0 , time >= 1.2 , text >= 0.11 && < 1.3 diff --git a/src/Network/OAuth.hs b/src/Network/OAuth.hs index 1475beb..cb4f08d 100644 --- a/src/Network/OAuth.hs +++ b/src/Network/OAuth.hs @@ -62,11 +62,11 @@ import qualified Network.OAuth.Types.Credentials as O import qualified Network.OAuth.Types.Params as O -- | Sign a request with a fresh set of parameters. Creates a fresh --- 'R.SystemRNG' using new entropy for each signing and thus is potentially +-- 'R.ChaChaDRG' using new entropy for each signing and thus is potentially -- /dangerous/ if used too frequently. In almost all cases, 'S.oauth' -- should be used instead. oauthSimple :: O.Cred ty -> O.Server -> C.Request -> IO C.Request oauthSimple cr srv req = do - entropy <- R.createEntropyPool - (req', _) <- S.oauth cr srv req (R.cprgCreate entropy :: R.SystemRNG) + entropy <- R.drgNew + (req', _) <- S.oauth cr srv req entropy return req' diff --git a/src/Network/OAuth/Signing.hs b/src/Network/OAuth/Signing.hs index b072360..6b0cb71 100644 --- a/src/Network/OAuth/Signing.hs +++ b/src/Network/OAuth/Signing.hs @@ -35,13 +35,13 @@ module Network.OAuth.Signing ( ) where -import qualified Blaze.ByteString.Builder as Blz import Control.Applicative -import Crypto.Hash.SHA1 (hash) -import Crypto.MAC.HMAC (hmac) +import qualified Blaze.ByteString.Builder as Blz +import Crypto.Hash (SHA1) +import Crypto.MAC.HMAC (HMAC, hmac) import Crypto.Random +import Data.ByteArray.Encoding (Base(Base64), convertToBase) import qualified Data.ByteString as S -import qualified Data.ByteString.Base64 as S64 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as SL import Data.Char (toUpper) @@ -58,7 +58,7 @@ import Network.OAuth.Util import Network.URI -- | Sign a request with a fresh set of parameters. -oauth :: CPRG gen => Cred ty -> Server -> C.Request -> gen -> IO (C.Request, gen) +oauth :: DRG gen => Cred ty -> Server -> C.Request -> gen -> IO (C.Request, gen) oauth creds sv req gen = do (oax, gen') <- freshOa creds gen return (sign oax sv req, gen') @@ -73,7 +73,8 @@ sign oax server req = in augmentRequest (parameterMethod server) params req makeSignature :: SignatureMethod -> S.ByteString -> S.ByteString -> S.ByteString -makeSignature HmacSha1 sigKey payload = S64.encode (hmac hash 64 sigKey payload) +makeSignature HmacSha1 sigKey payload = convertToBase Base64 hmac' + where hmac' = hmac sigKey payload :: HMAC SHA1 makeSignature Plaintext sigKey _ = sigKey -- | Augments whatever component of the 'C.Request' is specified by diff --git a/src/Network/OAuth/Simple.hs b/src/Network/OAuth/Simple.hs index e333147..08b0545 100644 --- a/src/Network/OAuth/Simple.hs +++ b/src/Network/OAuth/Simple.hs @@ -81,10 +81,10 @@ data OaConfig ty = -- | Perform authenticated requests using a shared 'C.Manager' and -- a particular set of 'O.Cred's. newtype OAuthT ty m a = - OAuthT { unOAuthT :: ReaderT (OaConfig ty) (StateT R.SystemRNG m) a } + OAuthT { unOAuthT :: ReaderT (OaConfig ty) (StateT R.ChaChaDRG m) a } deriving ( Functor, Applicative, Monad , MonadReader (OaConfig ty) - , MonadState R.SystemRNG + , MonadState R.ChaChaDRG , E.MonadCatch , E.MonadThrow , MonadIO @@ -100,8 +100,8 @@ runOAuthT OAuthT ty m a -> O.Cred ty -> O.Server -> O.ThreeLegged -> m a runOAuthT oat cr srv tl = do - entropy <- liftIO R.createEntropyPool - evalStateT (runReaderT (unOAuthT oat) (OaConfig cr srv tl)) (R.cprgCreate entropy) + gen <- liftIO R.drgNew + evalStateT (runReaderT (unOAuthT oat) (OaConfig cr srv tl)) gen runOAuth :: OAuth ty a -> O.Cred ty -> O.Server -> O.ThreeLegged -> IO a runOAuth = runOAuthT @@ -121,14 +121,14 @@ upgradeCred tok = liftM (Cred.upgradeCred tok . cred) ask -- | Given a 'Cred.ResourceToken' of some kind, run an inner 'OAuthT' session -- with the same configuration but new credentials. -upgrade :: (Cred.ResourceToken ty', Monad m) => O.Token ty' -> OAuthT ty' m a -> OAuthT ty m a +upgrade :: (Cred.ResourceToken ty', Monad m, MonadIO m) => O.Token ty' -> OAuthT ty' m a -> OAuthT ty m a upgrade tok oat = do - gen <- state R.cprgFork + gen <- liftIO R.drgNew conf <- ask let conf' = conf { cred = Cred.upgradeCred tok (cred conf) } lift $ evalStateT (runReaderT (unOAuthT oat) conf') gen -liftBasic :: MonadIO m => (R.SystemRNG -> OaConfig ty -> IO (a, R.SystemRNG)) -> OAuthT ty m a +liftBasic :: MonadIO m => (R.ChaChaDRG -> OaConfig ty -> IO (a, R.ChaChaDRG)) -> OAuthT ty m a liftBasic f = do gen <- get conf <- ask @@ -208,7 +208,7 @@ requestTokenProtocol man getVerifier = runEitherT $ do upE :: (Monad m, Functor m) => (e -> f) -> Either e b -> EitherT f m b upE f = liftE f . return -- This is just 'upgrade' played out in the EitherT monad. - upgradeE :: (Monad m, Cred.ResourceToken ty') => + upgradeE :: (Monad m, MonadIO m, Cred.ResourceToken ty') => Cred.Token ty' -> EitherT e (OAuthT ty' m) a -> EitherT e (OAuthT ty m) a upgradeE tok = EitherT . upgrade tok . runEitherT diff --git a/src/Network/OAuth/ThreeLegged.hs b/src/Network/OAuth/ThreeLegged.hs index d0ddf13..23e68d7 100644 --- a/src/Network/OAuth/ThreeLegged.hs +++ b/src/Network/OAuth/ThreeLegged.hs @@ -89,9 +89,9 @@ parseThreeLegged a b c d = -- -- Throws 'C.HttpException's. requestTemporaryTokenRaw - :: R.CPRG gen => O.Cred O.Client -> O.Server - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response SL.ByteString, gen) + :: R.DRG gen => O.Cred O.Client -> O.Server + -> ThreeLegged -> C.Manager -> gen + -> IO (C.Response SL.ByteString, gen) requestTemporaryTokenRaw cr srv (ThreeLegged {..}) man gen = do (oax, gen') <- O.freshOa cr gen let req = O.sign (oax { P.workflow = P.TemporaryTokenRequest callback }) srv temporaryTokenRequest @@ -105,9 +105,9 @@ requestTemporaryTokenRaw cr srv (ThreeLegged {..}) man gen = do -- -- Throws 'C.HttpException's. requestTemporaryToken - :: R.CPRG gen => O.Cred O.Client -> O.Server - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response (Either SL.ByteString (O.Token O.Temporary)), gen) + :: R.DRG gen => O.Cred O.Client -> O.Server + -> ThreeLegged -> C.Manager -> gen + -> IO (C.Response (Either SL.ByteString (O.Token O.Temporary)), gen) requestTemporaryToken cr srv tl man gen = do (raw, gen') <- requestTemporaryTokenRaw cr srv tl man gen return (tryParseToken <$> raw, gen') @@ -135,10 +135,10 @@ buildAuthorizationUrl cr (ThreeLegged {..}) = -- -- Throws 'C.HttpException's. requestPermanentTokenRaw - :: R.CPRG gen => O.Cred O.Temporary -> O.Server - -> P.Verifier - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response SL.ByteString, gen) + :: R.DRG gen => O.Cred O.Temporary -> O.Server + -> P.Verifier + -> ThreeLegged -> C.Manager -> gen + -> IO (C.Response SL.ByteString, gen) requestPermanentTokenRaw cr srv verifier (ThreeLegged {..}) man gen = do (oax, gen') <- O.freshOa cr gen let req = O.sign (oax { P.workflow = P.PermanentTokenRequest verifier }) srv permanentTokenRequest @@ -149,11 +149,11 @@ requestPermanentTokenRaw cr srv verifier (ThreeLegged {..}) man gen = do -- See also 'requestPermanentTokenRaw'. -- -- Throws 'C.HttpException's. -requestPermanentToken - :: R.CPRG gen => O.Cred O.Temporary -> O.Server - -> P.Verifier - -> ThreeLegged -> C.Manager -> gen - -> IO (C.Response (Either SL.ByteString (O.Token O.Permanent)), gen) +requestPermanentToken + :: R.DRG gen => O.Cred O.Temporary -> O.Server + -> P.Verifier + -> ThreeLegged -> C.Manager -> gen + -> IO (C.Response (Either SL.ByteString (O.Token O.Permanent)), gen) requestPermanentToken cr srv verifier tl man gen = do (raw, gen') <- requestPermanentTokenRaw cr srv verifier tl man gen return (tryParseToken <$> raw, gen') @@ -165,15 +165,14 @@ requestPermanentToken cr srv verifier tl man gen = do -- | Like 'requestTokenProtocol' but allows for specification of the -- 'C.ManagerSettings'. -requestTokenProtocol' - :: C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged - -> (URI -> IO P.Verifier) +requestTokenProtocol' + :: C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged + -> (URI -> IO P.Verifier) -> IO (Maybe (O.Cred O.Permanent)) requestTokenProtocol' mset cr srv tl getVerifier = do - entropy <- R.createEntropyPool + gen <- R.drgNew E.bracket (C.newManager mset) C.closeManager $ \man -> do - let gen = (R.cprgCreate entropy :: R.SystemRNG) - (respTempToken, gen') <- requestTemporaryToken cr srv tl man gen + (respTempToken, gen') <- requestTemporaryToken cr srv tl man gen case C.responseBody respTempToken of Left _ -> return Nothing Right tok -> do diff --git a/src/Network/OAuth/Types/Params.hs b/src/Network/OAuth/Types/Params.hs index f9f113d..2419212 100644 --- a/src/Network/OAuth/Types/Params.hs +++ b/src/Network/OAuth/Types/Params.hs @@ -21,8 +21,8 @@ module Network.OAuth.Types.Params where import Control.Applicative import Crypto.Random +import Data.ByteArray.Encoding (Base(Base64), convertToBase) import qualified Data.ByteString as S -import qualified Data.ByteString.Base64 as S64 import qualified Data.ByteString.Char8 as S8 import Data.Data import Data.Time @@ -178,12 +178,19 @@ emptyPin = OaPin { timestamp = Timestamp (UTCTime (ModifiedJulianDay 0) 0) -- | Creates a new, unique, unpredictable 'OaPin'. This should be used quickly -- as dependent on the OAuth server settings it may expire. -freshPin :: CPRG gen => gen -> IO (OaPin, gen) +freshPin :: DRG gen => gen -> IO (OaPin, gen) freshPin gen = do t <- Timestamp <$> getCurrentTime return (OaPin { timestamp = t, nonce = n }, gen') where - (n, gen') = withRandomBytes gen 8 S64.encode + (n, gen') = withRandomBytes gen 8 (convertToBase Base64) + +-- | generate @len random bytes and mapped the bytes to the function @f. +-- +-- This is equivalent to use Control.Arrow 'first' with 'randomBytesGenerate' +withRandomBytes :: DRG g => g -> Int -> (S.ByteString -> a) -> (a, g) +withRandomBytes rng len f = (f bs, rng') + where (bs, rng') = randomBytesGenerate len rng -- | Uses 'emptyPin' to create an empty set of params 'Oa'. emptyOa :: Cred ty -> Oa ty @@ -191,7 +198,7 @@ emptyOa creds = Oa { credentials = creds, workflow = Standard, pin = emptyPin } -- | Uses 'freshPin' to create a fresh, default set of params 'Oa'. -freshOa :: CPRG gen => Cred ty -> gen -> IO (Oa ty, gen) +freshOa :: DRG gen => Cred ty -> gen -> IO (Oa ty, gen) freshOa creds gen = do (pinx, gen') <- freshPin gen return (Oa { credentials = creds, workflow = Standard, pin = pinx }, gen')