Thanks for this. I think the best way to make use of this is to package up the logic specific to handling SSO requests in an independent library, so we can use it later.
That's not about you, or about this code. :) It's just that I am going to push back hard on having SSO be the second major feature we add to our website (or the third, or even the tenth). We'll see where that discussion goes. On Mon, Dec 05, 2016 at 04:13:42AM +0200, fr33domlover wrote: > From: fr33domlover <fr33domlo...@rel4tion.org> > > --- > website/Snowdrift.cabal | 7 ++++ > website/config/routes | 2 ++ > website/config/settings.yml | 4 +++ > website/src/Application.hs | 1 + > website/src/Discourse.hs | 73 > ++++++++++++++++++++++++++++++++++++++++ > website/src/Handler/Discourse.hs | 55 ++++++++++++++++++++++++++++++ > website/src/Settings.hs | 4 +++ > 7 files changed, 146 insertions(+) > create mode 100644 website/src/Discourse.hs > create mode 100644 website/src/Handler/Discourse.hs > > diff --git a/website/Snowdrift.cabal b/website/Snowdrift.cabal > index 9c1664c..b5cfaa5 100644 > --- a/website/Snowdrift.cabal > +++ b/website/Snowdrift.cabal > @@ -40,6 +40,7 @@ library > Avatar > Application > Css > + Discourse > Email > Foundation > Import > @@ -49,6 +50,7 @@ library > Settings.StaticFiles > Handler > Handler.Dashboard > + Handler.Discourse > Handler.PaymentInfo > Handler.Pledge > Handler.Project > @@ -74,6 +76,7 @@ library > , bytestring >= 0.9 && < 0.11 > , classy-prelude >= 0.10.2 > , classy-prelude-yesod >= 0.10.2 > + , cryptonite > , data-default > , errors > , esqueleto > @@ -82,8 +85,10 @@ library > , formattable > , hjsmin >= 0.1 > , http-client > + , http-types > , lens > , libravatar > + , memory > , mime-mail > , monad-logger >= 0.3 && < 0.4 > , nonce > @@ -99,6 +104,7 @@ library > , text >= 0.11 && < 2.0 > , time > , titlecase > + , transformers > , unordered-containers > , wai > , wai-extra >= 3.0 && < 3.1 > @@ -122,6 +128,7 @@ library > RecordWildCards > ScopedTypeVariables > TemplateHaskell > + TupleSections > TypeFamilies > ViewPatterns > > diff --git a/website/config/routes b/website/config/routes > index 9e4e079..30fdef8 100644 > --- a/website/config/routes > +++ b/website/config/routes > @@ -26,6 +26,8 @@ > /p/snowdrift SnowdriftProjectR GET > /pledge/snowdrift PledgeSnowdriftR POST DELETE > > +/discourse/sso DiscourseR GET > + > -- ## Backward compatibility routes > > -- Prevents breakage of external links to the old wiki. See > diff --git a/website/config/settings.yml b/website/config/settings.yml > index 3c30c0f..e4e30bb 100644 > --- a/website/config/settings.yml > +++ b/website/config/settings.yml > @@ -44,3 +44,7 @@ send-email: "_env:SD_EMAILS:false" > # chreekat for assistance. > stripe-secret-key: "_env:STRIPE_SECRET_KEY:" > stripe-publishable-key: "_env:STRIPE_PUBLISHABLE_KEY:" > + > +# Discourse SSO > +discourse-url: "https://discourse.snowdrift.coop"; > +discourse-sso-secret: "" > diff --git a/website/src/Application.hs b/website/src/Application.hs > index 8ccd6b2..761d3f8 100644 > --- a/website/src/Application.hs > +++ b/website/src/Application.hs > @@ -35,6 +35,7 @@ import qualified Yesod.GitRev as G > > import Handler > import Handler.Dashboard > +import Handler.Discourse > import Handler.PaymentInfo > import Handler.Pledge > import Handler.Project > diff --git a/website/src/Discourse.hs b/website/src/Discourse.hs > new file mode 100644 > index 0000000..cca0bb1 > --- /dev/null > +++ b/website/src/Discourse.hs > @@ -0,0 +1,73 @@ > +module Discourse where > + > +import Prelude > + > +import Crypto.Hash.Algorithms (SHA256) > +import Crypto.MAC.HMAC > +import Data.ByteArray.Encoding > +import Data.ByteString (ByteString) > +import Data.Maybe (catMaybes) > +import Data.Text (Text, pack) > +import Data.Text.Encoding (encodeUtf8) > +import Network.HTTP.Types.URI (renderSimpleQuery) > + > +import qualified Data.ByteString as B (drop) > + > +import Model > + > +-- | Information we send back to Discourse once the user logs in through our > +-- UI. > +data UserInfo = UserInfo > + { ssoEmail :: Text > + , ssoId :: UserId > + , ssoUsername :: Maybe Text > + , ssoFullName :: Maybe Text > + , ssoAvatarUrl :: Maybe Text > + , ssoBio :: Maybe Text > + } > + > +-- | Type restricted convenience wrapper that computes our HMAC. > +hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256 > +hmacSHA256 = hmac > + > +-- | Given secret known in advance and payload given in the query, compute > the > +-- HMAC-SHA256, to which Discourse refers as the signature. > +generateSig > + :: ByteString -- ^ Secret > + -> ByteString -- ^ Base64 encoded payload > + -> ByteString > +generateSig secret payload = > + convertToBase Base16 $ hmacGetDigest $ hmacSHA256 secret payload > + > +-- | This validates the payloads's authenticity (i.e. make sure it's really > our > +-- trusted local Discourse instance) by using the signature as a proof that > it > +-- knows the SSO secret. This is done by verifying that the HMAC-SHA256 of > the > +-- secret and the payload is identical to the signature. > +validateSig > + :: ByteString -- ^ SSO secret, same one you specify in Discourse settings > + -> ByteString -- ^ Base64 encoded payload sent by Discourse in the query > + -> ByteString -- ^ Signature sent by Discourse in the query > + -> Bool -- ^ Whether the computed sig and one passed are identical > +validateSig secret payload signature = generateSig secret payload == > signature > + > +-- | Get the nonce from the payload by decoding from Base64 and dropping the > +-- constant prefix. > +payloadToNonce :: ByteString -> Either String ByteString > +payloadToNonce = fmap (B.drop 6) . convertFromBase Base64 > + > +-- | Compute Base64 encoded payload to send back to Discourse after login > +userInfoPayload > + :: ByteString -- ^ Raw nonce string we extracted from input payload > + -> UserInfo -- ^ Info about the user we pass back to Discourse > + -> ByteString > +userInfoPayload nonce uinfo = > + let query = catMaybes $ map (\ (name, mval) -> fmap (name,) mval) > + [ ("nonce" , Just nonce) > + , ("email" , Just $ encodeUtf8 $ ssoEmail uinfo) > + , ("external_id", Just $ encodeUtf8 $ pack $ show $ ssoId uinfo) > + , ("username" , fmap encodeUtf8 $ ssoUsername uinfo) > + , ("name" , fmap encodeUtf8 $ ssoFullName uinfo) > + , ("avatar_url" , fmap encodeUtf8 $ ssoAvatarUrl uinfo) > + , ("bio" , fmap encodeUtf8 $ ssoBio uinfo) > + ] > + in convertToBase Base64 $ renderSimpleQuery False query > diff --git a/website/src/Handler/Discourse.hs > b/website/src/Handler/Discourse.hs > new file mode 100644 > index 0000000..d95f121 > --- /dev/null > +++ b/website/src/Handler/Discourse.hs > @@ -0,0 +1,55 @@ > +module Handler.Discourse (getDiscourseR) where > + > +import Import > +import Control.Lens > +import Control.Monad.Trans.Except > +import Avatar > +import Discourse > + > +maybeThrow :: Monad m => e -> Maybe a -> ExceptT e m a > +maybeThrow err Nothing = throwE err > +maybeThrow _ (Just x) = return x > + > +getDiscourseR :: Handler Html > +getDiscourseR = do > + result <- runExceptT $ do > + -- Extract payload param > + mpayload <- lift $ fmap encodeUtf8 <$> lookupGetParam "sso" > + payload <- maybeThrow "No payload" mpayload > + -- Extract sig param > + msig <- lift $ fmap encodeUtf8 <$> lookupGetParam "sig" > + sig <- maybeThrow "No sig" msig > + -- Get SSO secret from settings > + secret <- lift $ getsYesod $ appDiscourseSsoSecret . appSettings > + -- Verify signature > + unless (validateSig secret payload sig) $ throwE "Signature is > invalid" > + -- Extract nonce from payload > + nonce <- case payloadToNonce payload of > + Left err -> throwE $ "Payload invalid: " <> pack err > + Right n -> return n > + -- Perform authentication and fetch user info > + Entity uid u <- lift requireAuth > + avatar <- > + lift $ getUserAvatar (StaticR img_default_avatar_png) (Just u) > + let uinfo = UserInfo > + { ssoEmail = u ^. userEmail > + , ssoId = uid > + -- TODO no better option right now... > + , ssoUsername = Nothing > + -- TODO no better option right now... > + , ssoFullName = Nothing > + , ssoAvatarUrl = Just avatar > + -- TODO could link to Snowdrift user page > + , ssoBio = Nothing > + } > + -- Compute new payload and sig > + uinfoPayload = userInfoPayload nonce uinfo > + uinfoSig = generateSig secret uinfoPayload > + -- Send them back to Discourse > + baseUrl <- lift $ getsYesod $ appDiscourseUrl . appSettings > + let params = [("sso", uinfoPayload), ("sig", uinfoSig)] > + query = decodeUtf8 $ renderSimpleQuery True params > + return $ baseUrl <> "/session/sso_login" <> query > + case result of > + Left err -> invalidArgs [err] > + Right url -> redirect url > diff --git a/website/src/Settings.hs b/website/src/Settings.hs > index 74254f7..dd7afc5 100644 > --- a/website/src/Settings.hs > +++ b/website/src/Settings.hs > @@ -51,6 +51,8 @@ data AppSettings = AppSettings > -- ^ Whether to send emails > , appStripeSecretKey :: StripeKey > , appStripePublishableKey :: StripeKey > + , appDiscourseUrl :: Text > + , appDiscourseSsoSecret :: ByteString > } > > instance FromJSON AppSettings where > @@ -76,6 +78,8 @@ instance FromJSON AppSettings where > appSendMail <- o .:? "send-email" .!= not > runningDevelopment > appStripePublishableKey <- StripeKey . encodeUtf8 <$> o .: > "stripe-publishable-key" > appStripeSecretKey <- StripeKey . encodeUtf8 <$> o .: > "stripe-secret-key" > + appDiscourseUrl <- o .: "discourse-url" > + appDiscourseSsoSecret <- encodeUtf8 <$> o .: > "discourse-sso-secret" > > return AppSettings {..} > > -- > 1.9.1 > > _______________________________________________ > Dev mailing list > Dev@lists.snowdrift.coop > https://lists.snowdrift.coop/mailman/listinfo/dev
signature.asc
Description: Digital signature
_______________________________________________ Dev mailing list Dev@lists.snowdrift.coop https://lists.snowdrift.coop/mailman/listinfo/dev
