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
