What would the proper way to store an OAuth2 jwk in haskell? The certs i am retrieving are from https://www.googleapis.com/oauth2/v3/certs and I would like to avoid calling out for certs each time i need to verify the signature on a token. The options seem to be MVar, TVar, IORef, or the state monad although i am not quite sure how i would implement the state monad for this.
The basic steps would be the following (running behind a scotty server):
Receive Token from IDP
Decode Jwt with JWk's
If the decode fails due to a bad signature then check the endpoint for new certs and modify the current variable containing the cert
I am using jose-jwt, wreq, and scotty right now and have something that works but i would like to implement the approach that i am asking about rather than my existing approach.
module Main where
import ClassyPrelude
import Web.Scotty as S
import Network.Wreq as W
import Control.Lens as CL
import qualified Data.Text.Lazy as TL
import qualified Network.URI.Encode as URI
import Network.Wai.Middleware.RequestLogger
import Jose.Jwe
import Jose.Jwa
import Jose.Jwk
import Jose.Jwt
import Jose.Jws
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.List as DL
import qualified Data.ByteString.Base64 as B64
main :: IO ()
main = scotty 8080 $ do
middleware logStdoutDev
redirectCallback
oauthCallback
oauthGen
home
home :: ScottyM ()
home = do
S.get "/:word" $ do
beam <- S.param "word"
html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
redirectCallback :: ScottyM ()
redirectCallback = do
S.get "/redirect" $ do
let v = uriSchemeBuilder
redirect $ TL.fromStrict v
oauthCallback :: ScottyM ()
oauthCallback = do
matchAny "/goauth2callback" $ do
val <- body
pars <- S.params
c <- S.param "code" `rescue` (\_ -> return "haskell")
let c1 = c <> (""::Text)
r <- liftIO $ W.post "https://oauth2.googleapis.com/token"
[ "code" := (encodeUtf8 (c))
, "client_id" := (encodeUtf8 consumerAccess)
, "client_secret" := (encodeUtf8 consumerSecret)
, "redirect_uri" := (encodeUtf8 redirectURI)
, "grant_type" := ("authorization_code"::ByteString)
, "access_type" := ("offline"::ByteString)
]
let newUser = (r ^? responseBody)
case newUser of
Just b -> do
let jwt = decodeStrict (toStrict b) :: Maybe Value
case jwt of
Just (Object v) -> do
let s = HM.lookup "id_token" v
case s of
Just (String k) -> do
isValid <- liftIO $ validateToken (encodeUtf8 k)
liftIO $ print isValid
redirect "/hello_world"
_ -> redirect "/hello_world"
_ -> redirect "/hello_world"
Nothing -> redirect "/hello_world"
oauthGen :: ScottyM ()
oauthGen = do
matchAny "/callback_gen" $ do
val <- body
redirect "/hello_world"
consumerAccess :: Text
consumerAccess = "google public key"
consumerSecret :: Text
consumerSecret = "google secret key"
oAuthScopes :: Text
oAuthScopes = "https://www.googleapis.com/auth/userinfo.profile https://www.googleapis.com/auth/userinfo.email"
redirectURI :: Text
redirectURI = "http://localhost:8080/goauth2callback"
authURI :: Text
authURI = "https://accounts.google.com/o/oauth2/auth"
tokenURI :: Text
tokenURI = "https://oauth2.googleapis.com/token"
projectId :: Text
projectId = "project name"
responseType :: Text
responseType = "code"
oAuthUriBuilder :: [(Text, Text)]
oAuthUriBuilder =
[ ("client_id", consumerAccess)
, ("redirect_uri", redirectURI)
, ("scope", oAuthScopes)
, ("response_type", responseType)
]
uriSchemeBuilder :: Text
uriSchemeBuilder = authURI <> "?" <> (foldr (\x y -> (fst x ++ "=" ++ (URI.encodeText $ snd x)) ++ "&" ++ y) "" oAuthUriBuilder)
validateToken :: ByteString -> IO (Either JwtError JwtContent)
validateToken b = do
keySet <- retrievePublicKeys
case keySet of
Left e -> return $ Left $ KeyError "No keyset supplied"
Right k -> do
let header = JwsEncoding RS256
Jose.Jwt.decode k (Just $ header) b
retrievePublicKeys :: IO (Either String [Jwk])
retrievePublicKeys = do
r <- liftIO $ W.get "https://www.googleapis.com/oauth2/v3/certs"
case (r ^? responseBody) of
Nothing -> return $ Left "No body in response from google oauth api"
Just a -> do
let v = eitherDecode a :: Either String Value
case v of
Left e -> return $ Left e
Right (Object a) -> do
let keySet = HM.lookup "keys" a
case keySet of
Just k -> do
let kS = eitherDecode (Data.Aeson.encode k) :: Either String [Jwk]
return $ kS
_ -> return $ Left "No Key set provided"
_ -> return $ Left $ "Incorrect response type from https://www.googleapis.com/oauth2/v3/certs"
The specific part i am interested in replacing is:
retrievePublicKeys :: IO (Either String [Jwk])
retrievePublicKeys = do
r <- liftIO $ W.get "https://www.googleapis.com/oauth2/v3/certs"
case (r ^? responseBody) of
Nothing -> return $ Left "No body in response from google oauth api"
Just a -> do
let v = eitherDecode a :: Either String Value
case v of
Left e -> return $ Left e
Right (Object a) -> do
let keySet = HM.lookup "keys" a
case keySet of
Just k -> do
let kS = eitherDecode (Data.Aeson.encode k) :: Either String [Jwk]
return $ kS
_ -> return $ Left "No Key set provided"
_ -> return $ Left $ "Incorrect response type from https://www.googleapis.com/oauth2/v3/certs"
I've though about storing the Jwk's in redis but i would think that there is a better approach available.
The expected result is to be able to safely modify the cert that i am obtaining from google and using it on subsequent decodings without the need to constantly hit the endpoint.
(Note: Yes i know that it is bad practice to roll your own security but this is just out of interest)
If you go by something like three layers (ReaderT design pattern), then caching an IORef or TVar in the environment part in a ReaderT YourEnv IO would be the way to go. (atomicModifyIORef' should be sufficient.)
The Holmusk link will recommend the jwt package, but having just added, in another language at work, in-memory caching of Google's OAuth2 certificates, picking a JWT library in Haskell also appears very much like a feature trade-off:
For example, jwt explicitly states that it doesn't check the exp expiration timestamp, but as far as I can see, jose-jwt doesn't even address the exp expiration timestamp that it decodes. google-oauth2-jwt does, and embeds the endpoint (for good and for bad, harder to mock), but doesn't provide a lot of ergonomics beyond that. (Edit: It appears that jose does handle expiration, and that it's also the most popular of those I mentioned on Hackage.)
Related
I have a function that reads an Rsa key with the HsOpenSsl's readPrivateKey function unfortunately the signature of my function is this String -> IO (Maybe (IO Maybe RsaKey)). I need the PEM format and a Cryptonite.RSA key and I wrote the function mkRsaKey to make that from a string in PEM format.
Heres the code:
import qualified Crypto.PubKey.RSA as Rsa --from cryptonite
import OpenSSL.EVP.PKey -- from HsOpenSSL
import OpenSSL.PEM -- from HsOpenSSL
import OpenSSL.RSA -- from HsOpenSSL
import Prelude
data RsaKey = RsaKey
{ rsaKeyCryptoniteKey :: Rsa.PrivateKey,
rsaKeyStringRepr :: String
}
deriving (Show)
openSslKeyToCryptoniteKey :: RSAKeyPair -> Maybe Rsa.PrivateKey
openSslKeyToCryptoniteKey key = do
let d = rsaD key
let p = rsaP key
let q = rsaQ key
let mdP = rsaDMP1 key
let mdQ = rsaDMQ1 key
let mqinv = rsaIQMP key
let size = rsaSize key
let n = rsaN key
let e = rsaE key
dP <- mdP
dQ <- mdQ
qinv <- mqinv
let pub = Rsa.PublicKey size n e
return $ Rsa.PrivateKey pub d p q dP dQ qinv
openSslKeyToRsaKey :: RSAKeyPair -> IO (Maybe RsaKey)
openSslKeyToRsaKey key = do
stringRepr <- writePublicKey key
let maybeCryptoKey = openSslKeyToCryptoniteKey key
return $ do
cryptoKey <- maybeCryptoKey
return $ RsaKey cryptoKey stringRepr
mkRsaKey :: String -> IO (Maybe (IO (Maybe RsaKey)))
mkRsaKey privateKey = do
someOpenSslKey <- readPrivateKey privateKey PwNone
let openSslKey = toKeyPair someOpenSslKey
return $ openSslKeyToRsaKey <$> openSslKey
Now as you can see the type signature is in my sense not optimal I would like to have IO (Maybe RsaKey). How can I achieve this?
EDIT:
I actually managed to do it but I'm using unsafePerformIO:
mkRsaKey :: String -> IO (Maybe RsaKey)
mkRsaKey privateKey = do
someOpenSslKey <- readPrivateKey privateKey PwNone
return $ do
openSslKey <- toKeyPair someOpenSslKey
unsafePerformIO (openSslKeyToRsaKey $ openSslKey)
As far as I know you should never use unsafePerformIO would there be some way to do this without it?
Nice discovery with case. This is definitely not a place where you should be using unsafePerformIO. Here's a more compact way, for fun.
flattenMaybe :: (Monad m) => m (Maybe (m (Maybe a))) -> m (Maybe a)
flattenMaybe m = m >>= fromMaybe (return Nothing)
And for extra fun, the ability to flatten layers like this is a characteristic ability of monads; we're just using that ability on m (Maybe ...), also known as MaybeT. So we could also write it like this:
flattenMaybe = runMaybeT . join . fmap MaybeT . MaybeT
Doing the necessary wrapping/unwrapping to use join at MaybeT m (MaybeT m a) -> MaybeT m a.
Found a way to do it without unsafePerformIO the trick is to use a case statement which only uses the return function in the Nothing case. Here's the implementation:
mkRsaKey :: String -> IO (Maybe RsaKey)
mkRsaKey privateKey = do
someOpenSslKey <- readPrivateKey privateKey PwNone
let maybeOpenSslKey = toKeyPair someOpenSslKey
case maybeOpenSslKey of
Just key -> openSslKeyToRsaKey key
Nothing -> return Nothing
I am making some http calls using wreq and would like to catch any exception and return an Either type. I tried something like this but could not figure out how to manipulate the calls so it will type check.
-- exhaustive pattern match omitted here
safeGetUrl :: URL -> Maybe Login -> Maybe Password -> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BS.pack login) (BS.pack pass)
r <- getWith opts url `E.catch` handler
return $ Right r
where
handler :: HttpException -> Either String (Response LBS.ByteString)
handler (StatusCodeException s _ _) = do
return $ Left $ LBS.unpack (s ^. statusMessage)
I am pasting the type error below but I know the above code will not compile. The issue is r <- getWith opts url E.catch handler. The first part returns IO (Res... but the exception handler returns Either... I tried adding lifting the getWith.. into Either but that did not type check either.
Couldn't match type ‘Either String (Response LBS.ByteString)’
with ‘IO (Response LBS.ByteString)’
Expected type: HttpException -> IO (Response LBS.ByteString)
Actual type: HttpException
-> Either String (Response LBS.ByteString)
In the second argument of ‘catch’, namely ‘handler’
In a stmt of a 'do' block: r <- getWith opts url `catch` handler
Is there a way to catch this exception and return an IO Either type?
Since #jozefg answer, the API has changed a little bit and the answer doesn't compile anymore.
Here is an updated version that compiles:
import qualified Control.Exception as E
import Control.Lens
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as LBS
import Network.HTTP.Client
import Network.Wreq as NW
type URL = String
type Login = String
type Password = String
safeGetUrl ::
URL
-> Maybe Login
-> Maybe Password
-> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BSC.pack login) (BSC.pack pass)
(Right <$> getWith opts url) `E.catch` handler
where
handler :: HttpException -> IO (Either String (Response LBS.ByteString))
handler (HttpExceptionRequest _ (StatusCodeException r _)) =
return $ Left $ BSC.unpack (r ^. NW.responseStatus . statusMessage)
Your issue is that one side of the handle returns an unwrapped response (no Either) and the other side returns an Either-wrapped exception. You then attempt to wrap the response in an Either, which you do need to do, but it's just at the wrong place. You can fix this merely by switching where you do the wrapping
safeGetUrl :: URL -> Maybe Login -> Maybe Password -> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BS.pack login) (BS.pack pass)
(Right <$> getWith opts url) `E.catch` handler
where
handler :: HttpException -> IO (Either String (Response LBS.ByteString))
handler (StatusCodeException s _ _) = do
return $ Left $ LBS.unpack (s ^. statusMessage)
However there are some other problems with your functions, remember that unpack gives back Word8s not Char. You may want to import Data.ByteString.Char as the version of unpack defined in there should work better than LBS.unpack. Without your imports though I cannot confirm this definitively. The final (working) code for me is
import Control.Lens
import Network.Wreq
import Network.HTTP.Client
import qualified Control.Exception as E
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as LBS
type URL = String
type Login = String
type Password = String
safeGetUrl :: URL
-> Maybe Login
-> Maybe Password
-> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BSC.pack login) (BSC.pack pass)
(Right <$> getWith opts url) `E.catch` handler
where
handler :: HttpException -> IO (Either String (Response LBS.ByteString))
handler (StatusCodeException s _ _) = do
return $ Left $ BSC.unpack (s ^. statusMessage)
I am trying to use an exception to skip parts of the code here. Instead of getting caught by catcheE and resuming normal behavior all following actions in the mapM_ chain get skipped.
I looked at this question and it appears that catchE ~ main and checkMaybe ~ intercept.
I also checked the implementation of mapM_to be sure it does what i want it to, but i don't understand how the Left value can escape dlAsset to affect the behavior of mapM_.
I refactored this from a version where i simply used an empty string as an exception marker for the failed lookup. In that version checkMaybe just returned a Right value immediately and it worked (matching on "" to 'catch')
import Data.HashMap.Strict as HM hiding (map)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Char8 as BSC8
import qualified JSONParser as P -- my module
retrieveAssets :: (Text -> Text) -> ExceptT Text IO ()
retrieveAssets withName = withManager $ (lift ((HM.keys . P.assets)
<$> P.raw) ) >>= mapM_ f
where
f = \x -> dlAsset x "0.1246" (withName x)
dlAsset :: Text -> Text -> Text -> ReaderT Manager (ExceptT Text IO) ()
dlAsset name size dest = do
req <- lift $ (P.assetLookup name size <$> P.raw) >>= checkMaybe
name >>= parseUrl . unpack -- lookup of a url
res <- httpLbs req
lift $ (liftIO $ BS.writeFile (unpack dest) $ responseBody res)
`catchE` (\_ -> return ()) -- always a Right value?
where
checkMaybe name a = case a of
Nothing -> ExceptT $ fmap Left $ do
BSC8.appendFile "./resources/images/missingFiles.txt" $
BSC8.pack $ (unpack name) ++ "\n"
putStrLn $ "lookup of " ++ (unpack name) ++ " failed"
return name
Just x -> lift $ pure x
(had to reformat to become somewhat readable here)
edit: i'd like to understand what actually happens here, that would probably help me more than knowing which part of the code is wrong.
The problem is that your call to catchE only covered the very last line of dlAsset. It needs to be moved to the left of the do-notation indentation level to cover all of the do notation.
I'm playing with Channels in Haskell. I want to do some IO actions in parallel until one of them fails, then collect all the results into a list.
This code errors with Exception <<loop>>. How can I get it to work with getChanContents? All of the examples I've seen assume they know how many messages are on the channel.
Is there a cleaner way to collect a bunch of results from workers?
module UrlPatterns where
import Control.Concurrent
import Types
import Text.HTML.Scalpel
import Data.Monoid ((<>))
import Control.Concurrent.Chan
import Control.Applicative
import Data.Maybe (isJust, catMaybes)
import Data.List (takeWhile)
-- find all valid links under a domain that follow the pattern:
-- http://example.com/pages/(1..N)
-- as soon as one is missing, return a list of all the ones you found
findIncrementing :: URL -> IO [Link]
findIncrementing base = do
let num = 1
-- find channel
cfind <- newChan
writeChan cfind (base, num)
-- results channel
cdone <- newChan
forkIO $ worker cfind cdone
-- collect the results
results <- getChanContents cdone
let results = takeWhile isJust results :: [Maybe Link]
print results
return []
worker :: Chan (URL, Int) -> Chan (Maybe Link) -> IO ()
worker next done = loop
where
loop = do
(base, num) <- readChan next
let url = pageUrl base num
putStrLn $ "FETCHING: " <> url
mt <- findPageTitle url
case mt of
Nothing -> do
writeChan done Nothing
putStrLn ("Missed " <> show num)
Just t -> do
writeChan done $ Just $ Link url t
writeChan next (base, num+1)
loop
scrapeTitle :: Scraper String String
scrapeTitle = text "title"
findPageTitle :: URL -> IO (Maybe String)
findPageTitle url = scrapeURL url scrapeTitle
pageUrl :: URL -> Int -> URL
pageUrl base num = base <> show num
Thanks to #bartavelle. I had an error unrelated to the channel code. Here's the relevant fix:
-- collect the results
results <- getChanContents cdone
let links = catMaybes $ takeWhile isJust results
return links
This seems like a reasonable thing to want, but I'm having type troubles. I'd like to have a Client that can send a list of options to a Server, which will choose one and return the chosen element. So something like this:
module Toy where
import Pipes
asker :: Monad m => () -> Client ([a], a -> String) a m ()
asker () = do
_ <- request ([0.0, 2.0], show)
_ <- request (["3", "4"], show)
return ()
The idea is that the server can call the a -> String function on each element of the list to display them to a user. I'd like to be able to vary a, as long as the list and function match.
Is something like this possible? Maybe the constraints I want can be encoded into a GADT somehow?
You can't do it quite the way you asked, but you can cheat a little bit and get something that's almost as good:
{-# LANGUAGE ExistentialQuantification #-}
module Toy where
import Control.Monad
import Pipes
import Pipes.Prelude (foreverK)
data Request = forall a . Request [a] (a -> String)
asker :: Monad m => () -> Client Request Int m ()
asker () = do
_ <- request (Request [0.0, 2.0] show)
_ <- request (Request ["3", "4"] show)
return ()
server :: Request -> Server Request Int IO r
server = foreverK $ \req -> case req of
Request as f -> do
choice <- lift $ do
let select = do
putStrLn "Select an option"
forM_ (zip [0..] as) $ \(n, a) ->
putStrLn $ show n ++ ": " ++ f a
n <- readLn
if (n >= length as)
then do
putStrLn "Invalid selection"
select
else return n
select
respond choice
Instead of returning back the value selected, you return back an Int corresponding to the index of the selected element. The rest is just using ExistentialQuantification.
Like others recommended, I suggest that you actually just send a list of Strings instead of using the existential quantification trick, but I included it just to show how that would be done just in case you were curious.