diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2013, Felipe Lessa + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Felipe Lessa nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Yesod/Auth/DeskCom.hs b/src/Yesod/Auth/DeskCom.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/DeskCom.hs @@ -0,0 +1,255 @@ +module Yesod.Auth.DeskCom + ( YesodDeskCom(..) + , deskComCreateCreds + , DeskComCredentials + , DeskComUser(..) + , DeskComUserId(..) + , DeskComCustomField + , DeskCom + , getDeskCom + , deskComLoginRoute + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Default (Default(..)) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Pred(ClassP), Type(VarT), mkName) +import Network.HTTP.Types (renderSimpleQuery) +import Yesod.Auth +import Yesod.Core +import qualified Crypto.Cipher.AES as AES +import qualified Crypto.Classes as Crypto +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.HMAC as HMAC +import qualified Crypto.Padding as Padding +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Time as TI + + +-- | Type class that you need to implement in order to support +-- Desk.com remote authentication. +-- +-- /Minimal complete definition:/ everything except for 'deskComTokenTimeout'. +class YesodAuth master => YesodDeskCom master where + -- | The credentials needed to use Multipass. Use + -- 'deskComCreateCreds'. We recommend caching the resulting + -- 'DeskComCredentials' value on your foundation data type + -- since creating it is an expensive operation. + deskComCredentials :: master -> DeskComCredentials + + -- | Gather information that should be given to Desk.com about + -- an user. Please see 'DeskComUser' for more information + -- about what these fields mean. + -- + -- Simple example: + -- + -- @ + -- deskComUserInfo = do + -- Entity uid user <- 'requireAuth' + -- return 'def' { 'duName' = userName user + -- , 'duEmail' = userEmail user } + -- @ + -- + -- Advanced example: + -- + -- @ + -- deskComUserInfo = do + -- uid <- 'requireAuthId' + -- render <- 'getUrlRender' + -- runDB $ do + -- Just user <- get uid + -- Just org <- get (userOrganization user) + -- return 'def' { 'duName' = userName user + -- , 'duEmail' = userEmail user + -- , 'duOrganization' = Just (organizationName org) + -- , 'duRemotePhotoURL' = Just (render $ UserPhotoR uid) + -- } + -- @ + -- + -- /Note:/ although I don't recomend this and I don't see any + -- reason why you would do it, it /is/ possible to use + -- 'maybeAuth' instead of 'requireAuth' and login on Desk.com + -- with some sort of guest user should the user not be logged + -- in. + deskComUserInfo :: GHandler DeskCom master DeskComUser + + -- | Each time we login an user on Desk.com, we create a token. + -- This function defines how much time the token should be + -- valid before expiring. Should be greater than 0. Defaults + -- to 5 minutes. + deskComTokenTimeout :: master -> TI.NominalDiffTime + deskComTokenTimeout _ = 300 -- seconds + + +-- | Create the credentials data type used by this library. This +-- function is relatively expensive (uses SHA1 and AES), so +-- you'll probably want to cache its result. +deskComCreateCreds :: + T.Text -- ^ The name of your site (e.g., @\"foo\"@ if your + -- site is at @http://foo.desk.com/@). + -> T.Text -- ^ The domain of your site + -- (e.g. @\"foo.desk.com\"@). + -> T.Text -- ^ The Multipass API key, a shared secret between + -- Desk.com and your site. + -> DeskComCredentials +deskComCreateCreds site domain apiKey = DeskComCredentials site domain aesKey hmacKey + where + -- Yes, I know, Desk.com's crypto is messy. + aesKey = AES.initKey . B.take 16 . SHA1.hash . TE.encodeUtf8 $ apiKey <> site + hmacKey = HMAC.MacKey $ TE.encodeUtf8 apiKey + + +-- | Credentials used to access your Desk.com's Multipass. +data DeskComCredentials = + DeskComCredentials + { dccSite :: !T.Text + , dccDomain :: !T.Text + , dccAesKey :: !AES.Key + , dccHmacKey :: !(HMAC.MacKey SHA1.Ctx SHA1.SHA1) + } + + +-- | Information about a user that is given to 'DeskCom'. Please +-- see Desk.com's documentation +-- () in order to see +-- more details of how theses fields are interpreted. +-- +-- Only 'duName' and 'duEmail' are required. We suggest using +-- 'def'. +data DeskComUser = + DeskComUser + { duName :: Text + -- ^ User name, at least two characters. (required) + , duEmail :: Text + -- ^ E-mail address. (required) + , duUserId :: DeskComUserId + -- ^ Desk.com expects an string to be used as the ID of the + -- user on their system. Defaults to 'UseYesodAuthId'. + , duCustomFields :: [DeskComCustomField] + -- ^ Custom fields to be set. + , duRedirectTo :: Maybe Text + -- ^ When @Just url@, forces the user to be redirected to + -- @url@ after being logged in. Otherwise, the user is + -- redirected either to the page they were trying to view (if + -- any) or to your portal page at Desk.com. + } deriving (Eq, Ord, Show, Read) + +-- | Fields 'duName' and 'duEmail' are required, so 'def' will be +-- 'undefined' for them. +instance Default DeskComUser where + def = DeskComUser + { duName = req "duName" + , duEmail = req "duEmail" + , duUserId = def + , duCustomFields = [] + , duRedirectTo = Nothing + } + where req fi = error $ "DeskComUser's " ++ fi ++ " is a required field." + + +-- | Which external ID should be given to Desk.com. +data DeskComUserId = + UseYesodAuthId + -- ^ Use the user ID from @persistent@\'s database. This is + -- the recommended and default value. + | Explicit Text + -- ^ Use this given value. + deriving (Eq, Ord, Show, Read) + +-- | Default is 'UseYesodAuthId'. +instance Default DeskComUserId where + def = UseYesodAuthId + + +-- | The value of a custom customer field as @(key, value)@. +-- Note that you have prefix your @key@ with @\"custom_\"@. +type DeskComCustomField = (Text, Text) + + +---------------------------------------------------------------------- + + +-- | Data type for @yesod-auth-deskCom@\'s subsite. +data DeskCom = DeskCom + + +-- | Create a new 'DeskCom', use this on your @config/routes@ file. +getDeskCom :: a -> DeskCom +getDeskCom = const DeskCom + + +mkYesodSub "DeskCom" + [ClassP ''YesodDeskCom [VarT $ mkName "master"]] + [parseRoutes| + / DeskComLoginR GET +|] + + +-- | Redirect the user to Desk.com such that they're already +-- logged in when they arrive. For example, you may use +-- @deskComLoginRoute@ when the user clicks on a \"Support\" item +-- on a menu. +deskComLoginRoute :: Route DeskCom +deskComLoginRoute = DeskComLoginR + + +-- | Route used by the Desk.com remote authentication. Works both +-- when Desk.com call us and when we call them. +getDeskComLoginR :: YesodDeskCom master => GHandler DeskCom master () +getDeskComLoginR = do + -- Get generic info. + y <- getYesod + let DeskComCredentials {..} = deskComCredentials y + + -- Get the expires timestamp. + expires <- TI.addUTCTime (deskComTokenTimeout y) <$> liftIO TI.getCurrentTime + + -- Get information about the currently logged user. + DeskComUser {..} <- deskComUserInfo + userId <- case duUserId of + UseYesodAuthId -> toPathPiece <$> requireAuthId + Explicit x -> return x + + -- Create Multipass token. + let toStrict = B.concat . BL.toChunks + deskComEncode + = fst . B.spanEnd (== 61) -- remove trailing '=' per Desk.com + . B64URL.encode -- base64url encoding + encrypt + = deskComEncode -- encode as modified base64url + . AES.encryptCBC dccAesKey blankIV -- encrypt with AES128-CBC + . Padding.padPKCS5 16 -- PKCS#5 padding + . toStrict . A.encode . A.object -- encode as JSON + sign + = B64.encode . Crypto.encode -- encode as normal base64 (why??? =[) + . HMAC.hmac' dccHmacKey -- sign using HMAC-SHA1 + multipass = encrypt $ + "uid" A..= userId : + "expires" A..= expires : + "customer_email" A..= duEmail : + "customer_name" A..= duName : + [ "to" A..= to | Just to <- return duRedirectTo ] ++ + [ ("customer_" <> k) A..= v | (k, v) <- duCustomFields ] + signature = sign multipass + query = [("multipass", multipass), ("signature", signature)] + + -- Redirect to Desk.com + redirect $ T.concat [ "http://" + , dccDomain + , "/customer/authentication/multipass/callback?" + , TE.decodeUtf8 (renderSimpleQuery False query) + ] + + +-- | A blank IV consisting of NUL bytes. Yes, Desk.com's messy +-- crypto avoids using IVs! +blankIV :: AES.IV +blankIV = AES.IV (B.replicate 16 0) diff --git a/yesod-auth-deskcom.cabal b/yesod-auth-deskcom.cabal new file mode 100644 --- /dev/null +++ b/yesod-auth-deskcom.cabal @@ -0,0 +1,60 @@ +Name: yesod-auth-deskcom +Version: 1.0 +Synopsis: Desk.com remote authentication support for Yesod apps. +Homepage: https://github.com/meteficha/yesod-auth-deskcom +License: BSD3 +License-file: LICENSE +Author: Felipe Lessa +Maintainer: Felipe Lessa +Category: Web, Yesod +Build-type: Simple +Cabal-version: >= 1.6 + +Description: + This package allows users of your website to login into + Desk.com automatically using Desk.com's Multipass SSO (single + sign-on, ). + . + Note that this is an unusual @yesod-auth-*@ package. We do not + define an @AuthPlugin@ because the user can't log in to your + website via Desk.com (it's the opposite, they login in Desk.com + via your website). Instead, this plugin defines an Yesod + subsite that you may include on your site; the subsite defines + a route that accepts incoming users from Desk.com and + authenticates them. + +Source-repository head + type: git + location: git://github.com/meteficha/yesod-auth-deskcom.git + +Library + hs-source-dirs: src + + Build-depends: base >= 4.3 && < 5 + , time >= 1.1 && < 2 + , template-haskell + , transformers >= 0.1.3 && < 0.4 + , bytestring >= 0.9 + , text >= 0.7 && < 0.12 + , data-default + , base64-bytestring >= 1.0 + , cryptohash >= 0.6 + , cipher-aes >= 0.1 + , crypto-api >= 0.10 + , aeson >= 0.6 + , http-conduit + , http-types >= 0.7 + , yesod-core == 1.1.* + , yesod-auth == 1.1.* + + Exposed-modules: Yesod.Auth.DeskCom + Extensions: + FlexibleInstances + GADTs + MultiParamTypeClasses + OverloadedStrings + QuasiQuotes + RecordWildCards + TemplateHaskell + TypeFamilies + GHC-options: -Wall