{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Auth.DeskCom
( YesodDeskCom(..)
, deskComCreateCreds
, DeskComCredentials
, DeskComUser(..)
, DeskComUserId(..)
, DeskComCustomField
, DeskCom
, initDeskCom
, deskComLoginRoute
, deskComMaybeLoginRoute
) where
import Control.Applicative ((<$>))
import Data.Default (Default(..))
import Data.Monoid ((<>))
import Data.Text (Text)
import Network.HTTP.Types (renderSimpleQuery)
import Yesod.Auth
import Yesod.Core
import qualified Crypto.Cipher.AES as AES
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Padding as Padding
import qualified "crypto-random" Crypto.Random
import Crypto.Hash (hmac, SHA1, Digest, hmacGetDigest)
import Data.Byteable (toBytes)
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.IORef as I
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Time as TI
import Yesod.Auth.DeskCom.Data
-- | Type class that you need to implement in order to support
-- Desk.com remote authentication.
--
-- /Minimal complete definition:/ everything except for 'deskComTokenTimeout'.
class YesodAuthPersist 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 :: HandlerT master IO 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 uid = do
-- user <- runDB $ get uid
-- return 'def' { 'duName' = userName user
-- , 'duEmail' = userEmail user }
-- @
--
-- Advanced example:
--
-- @
-- deskComUserInfo uid = do
-- 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 :: AuthId master -> HandlerT master IO 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
instance YesodDeskCom master => YesodSubDispatch DeskCom (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesDeskCom)
-- | 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.initAES . B.take 16 . SHA1.hash . TE.encodeUtf8 $ apiKey <> site
hmacKey = TE.encodeUtf8 apiKey
-- | Credentials used to access your Desk.com's Multipass.
data DeskComCredentials =
DeskComCredentials
{ dccSite :: !T.Text
, dccDomain :: !T.Text
, dccAesKey :: !AES.AES
, dccHmacKey :: !B.ByteString -- HMAC.MacKey ?????? SHA1
}
-- | Information about a user that is given to 'DeskCom'. Please
-- see Desk.com's documentation
-- (<http://dev.desk.com/docs/portal/multipass>) 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)
----------------------------------------------------------------------
-- | Redirect the user to Desk.com such that they're already
-- logged in when they arrive. For example, you may use
-- @deskComLoginRoute@ as the login URL on Multipass config.
deskComLoginRoute :: Route DeskCom
deskComLoginRoute = DeskComLoginR
-- | If the user is logged in, redirect them to Desk.com such
-- that they're already logged in when they arrive (same as
-- 'deskComLoginRoute'). Otherwise, redirect them to Desk.com
-- without asking for credentials. For example, you may use
-- @deskComMaybeLoginRoute@ when the user clicks on a \"Support\"
-- item on a menu.
deskComMaybeLoginRoute :: Route DeskCom
deskComMaybeLoginRoute = DeskComMaybeLoginR
-- | Route used by the Desk.com remote authentication. Works
-- both when Desk.com call us and when we call them. Forces user
-- to be logged in.
getDeskComLoginR :: YesodDeskCom master
=> HandlerT DeskCom (HandlerT master IO) ()
getDeskComLoginR = lift requireAuthId >>= redirectToMultipass
-- | Same as 'getDeskComLoginR' if the user is logged in,
-- otherwise redirect to the Desk.com portal without asking for
-- credentials.
getDeskComMaybeLoginR :: YesodDeskCom master
=> HandlerT DeskCom (HandlerT master IO) ()
getDeskComMaybeLoginR = lift maybeAuthId >>= maybe redirectToPortal redirectToMultipass
-- | Redirect the user to the main Desk.com portal.
redirectToPortal :: YesodDeskCom master => HandlerT DeskCom (HandlerT master IO) ()
redirectToPortal = do
DeskComCredentials {..} <- lift deskComCredentials
redirect $ T.concat [ "http://", dccDomain, "/" ]
-- | Redirect the user to the multipass login.
redirectToMultipass :: YesodDeskCom master
=> AuthId master
-> HandlerT DeskCom (HandlerT master IO) ()
redirectToMultipass uid = do
-- Get generic info.
y <- lift getYesod
DeskComCredentials {..} <- lift deskComCredentials
-- Get the expires timestamp.
expires <- TI.addUTCTime (deskComTokenTimeout y) <$> liftIO TI.getCurrentTime
-- Get information about the currently logged user.
DeskComUser {..} <- lift (deskComUserInfo uid)
userId <- case duUserId of
UseYesodAuthId -> toPathPiece <$> lift requireAuthId
Explicit x -> return x
-- Generate an IV.
iv <- deskComRandomIV
-- 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 iv -- encrypt with AES128-CBC
. (iv <>) -- prepend the IV
. Padding.padPKCS5 16 -- PKCS#5 padding
. toStrict . A.encode . A.object -- encode as JSON
sign
= B64.encode -- encode as normal base64 (why??? =[)
. (toBytes :: Digest SHA1 -> B.ByteString)
. hmacGetDigest
. 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)
]
-- | Randomly generate an IV.
deskComRandomIV :: HandlerT DeskCom (HandlerT master IO) B.ByteString
deskComRandomIV = do
var <- deskComCprngVar <$> getYesod
liftIO $ I.atomicModifyIORef var $
\g -> let (bs, g') = Crypto.Random.cprgGenerate 16 g
in (g', g' `seq` bs)