From: fr33domlover <fr33domlo...@rel4tion.org>
---
website/Snowdrift.cabal | 8 ++++
website/config/routes | 2 +
website/config/settings.yml | 3 ++
website/src/Application.hs | 1 +
website/src/Discourse.hs | 86 ++++++++++++++++++++++++++++++++++++++++
website/src/Handler/Discourse.hs | 49 +++++++++++++++++++++++
website/src/Settings.hs | 2 +
7 files changed, 151 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..8eca05d 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
@@ -70,10 +72,12 @@ library
, crowdmatch
-- Other
, aeson >= 0.6 && < 0.12
+ , base64-bytestring
, blaze-html
, bytestring >= 0.9 && < 0.11
, classy-prelude >= 0.10.2
, classy-prelude-yesod >= 0.10.2
+ , cryptonite
, data-default
, errors
, esqueleto
@@ -82,8 +86,10 @@ library
, formattable
, hjsmin >= 0.1
, http-client
+ , http-types
, lens
, libravatar
+ , memory
, mime-mail
, monad-logger >= 0.3 && < 0.4
, nonce
@@ -99,6 +105,7 @@ library
, text >= 0.11 && < 2.0
, time
, titlecase
+ , transformers
, unordered-containers
, wai
, wai-extra >= 3.0 && < 3.1
@@ -122,6 +129,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..61ff751 100644
--- a/website/config/settings.yml
+++ b/website/config/settings.yml
@@ -44,3 +44,6 @@ 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-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..83106bb
--- /dev/null
+++ b/website/src/Discourse.hs
@@ -0,0 +1,86 @@
+module Discourse where
+
+import Prelude
+
+import Control.Monad.Trans.Except
+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, decodeUtf8')
+import Network.HTTP.Types.URI (renderSimpleQuery, parseSimpleQuery)
+
+import qualified Data.ByteString as B (drop)
+import qualified Data.ByteString.Base64 as B64 (decodeLenient)
+
+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 and the return URL from the payload by decoding from Base64
+-- and extracting the parameter values.
+--
+-- We use lenient decoding here because Discourse doesn't seem to add the
+-- necessary padding for strictly by-the-spec Base64 encoding.
+parsePayload :: ByteString -> Either String (ByteString, Text)
+parsePayload b = runExcept $ do
+ let params = parseSimpleQuery $ B64.decodeLenient b
+ nonce <- maybe (throwE "Nonce is missing") return $ lookup "nonce" params
+ burl <- maybe (throwE "URL is missing") return $
+ lookup "return_sso_url" params
+ let mapLeft f (Left x) = Left $ f x
+ mapLeft _ (Right x) = Right x
+ url <- except $ mapLeft show $ decodeUtf8' burl
+ return (nonce, url)
+
+-- | 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..4d69a68
--- /dev/null
+++ b/website/src/Handler/Discourse.hs
@@ -0,0 +1,49 @@
+module Handler.Discourse (getDiscourseR) where
+
+import Import
+import Control.Lens
+import Control.Monad.Trans.Except
+import Avatar
+import Discourse
+
+getDiscourseR :: Handler Html
+getDiscourseR = do
+ result <- runExceptT $ do
+ -- Extract payload param
+ mpayload <- lift $ fmap encodeUtf8 <$> lookupGetParam "sso"
+ payload <- maybe (throwE "No payload") return mpayload
+ -- Extract sig param
+ msig <- lift $ fmap encodeUtf8 <$> lookupGetParam "sig"
+ sig <- maybe (throwE "No sig") return msig
+ -- Get SSO secret from settings
+ secret <- lift $ getsYesod $ appDiscourseSsoSecret . appSettings
+ -- Verify signature
+ unless (validateSig secret payload sig) $ throwE "Signature is invalid"
+ -- Extract nonce and return URL from payload
+ (nonce, baseUrl) <- case parsePayload payload of
+ Left err -> throwE $ "Payload invalid: " <> pack err
+ Right p -> return p
+ -- 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
+ let params = [("sso", uinfoPayload), ("sig", uinfoSig)]
+ return $ baseUrl <> decodeUtf8 (renderSimpleQuery True params)
+ 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..dd6f270 100644
--- a/website/src/Settings.hs
+++ b/website/src/Settings.hs
@@ -51,6 +51,7 @@ data AppSettings = AppSettings
-- ^ Whether to send emails
, appStripeSecretKey :: StripeKey
, appStripePublishableKey :: StripeKey
+ , appDiscourseSsoSecret :: ByteString
}
instance FromJSON AppSettings where
@@ -76,6 +77,7 @@ instance FromJSON AppSettings where
appSendMail <- o .:? "send-email" .!= not
runningDevelopment
appStripePublishableKey <- StripeKey . encodeUtf8 <$> o .:
"stripe-publishable-key"
appStripeSecretKey <- StripeKey . encodeUtf8 <$> o .:
"stripe-secret-key"
+ 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
