module Yesod.Auth.DeskCom
( YesodDeskCom(..)
, deskComCreateCreds
, DeskComCredentials
, DeskComUser(..)
, DeskComUserId(..)
, DeskComCustomField
, DeskCom
, initDeskCom
, deskComLoginRoute
, deskComMaybeLoginRoute
) where
import Control.Applicative ((<$>))
import Crypto.Hash.CryptoAPI (SHA1)
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.Classes as Crypto
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.HMAC as HMAC
import qualified Crypto.Padding as Padding
import qualified Crypto.Random.AESCtr as CPRNG
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
class YesodAuthPersist master => YesodDeskCom master where
deskComCredentials :: master -> DeskComCredentials
deskComUserInfo :: AuthId master -> HandlerT master IO DeskComUser
deskComTokenTimeout :: master -> TI.NominalDiffTime
deskComTokenTimeout _ = 300
instance YesodDeskCom master => YesodSubDispatch DeskCom (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesDeskCom)
deskComCreateCreds ::
T.Text
-> T.Text
-> T.Text
-> DeskComCredentials
deskComCreateCreds site domain apiKey = DeskComCredentials site domain aesKey hmacKey
where
aesKey = AES.initKey . B.take 16 . SHA1.hash . TE.encodeUtf8 $ apiKey <> site
hmacKey = TE.encodeUtf8 apiKey
data DeskComCredentials =
DeskComCredentials
{ dccSite :: !T.Text
, dccDomain :: !T.Text
, dccAesKey :: !AES.Key
, dccHmacKey :: !B.ByteString
}
data DeskComUser =
DeskComUser
{ duName :: Text
, duEmail :: Text
, duUserId :: DeskComUserId
, duCustomFields :: [DeskComCustomField]
, duRedirectTo :: Maybe Text
} deriving (Eq, Ord, Show, Read)
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."
data DeskComUserId =
UseYesodAuthId
| Explicit Text
deriving (Eq, Ord, Show, Read)
instance Default DeskComUserId where
def = UseYesodAuthId
type DeskComCustomField = (Text, Text)
deskComLoginRoute :: Route DeskCom
deskComLoginRoute = DeskComLoginR
deskComMaybeLoginRoute :: Route DeskCom
deskComMaybeLoginRoute = DeskComMaybeLoginR
getDeskComLoginR :: YesodDeskCom master
=> HandlerT DeskCom (HandlerT master IO) ()
getDeskComLoginR = lift requireAuthId >>= redirectToMultipass
getDeskComMaybeLoginR :: YesodDeskCom master
=> HandlerT DeskCom (HandlerT master IO) ()
getDeskComMaybeLoginR = lift maybeAuthId >>= maybe redirectToPortal redirectToMultipass
redirectToPortal :: YesodDeskCom master => HandlerT DeskCom (HandlerT master IO) ()
redirectToPortal = do
y <- lift getYesod
let DeskComCredentials {..} = deskComCredentials y
redirect $ T.concat [ "http://", dccDomain, "/" ]
redirectToMultipass :: YesodDeskCom master
=> AuthId master
-> HandlerT DeskCom (HandlerT master IO) ()
redirectToMultipass uid = do
y <- lift getYesod
let DeskComCredentials {..} = deskComCredentials y
expires <- TI.addUTCTime (deskComTokenTimeout y) <$> liftIO TI.getCurrentTime
DeskComUser {..} <- lift (deskComUserInfo uid)
userId <- case duUserId of
UseYesodAuthId -> toPathPiece <$> lift requireAuthId
Explicit x -> return x
iv@(AES.IV ivBS) <- deskComRandomIV
let toStrict = B.concat . BL.toChunks
deskComEncode
= fst . B.spanEnd (== 61)
. B64URL.encode
encrypt
= deskComEncode
. AES.encryptCBC dccAesKey iv
. (ivBS <>)
. Padding.padPKCS5 16
. toStrict . A.encode . A.object
sign
= B64.encode . Crypto.encode
. HMAC.hmac' hmacKey
hmacKey :: HMAC.MacKey ctx SHA1
hmacKey = HMAC.MacKey dccHmacKey
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 $ T.concat [ "http://"
, dccDomain
, "/customer/authentication/multipass/callback?"
, TE.decodeUtf8 (renderSimpleQuery False query)
]
deskComRandomIV :: HandlerT DeskCom (HandlerT master IO) AES.IV
deskComRandomIV = do
var <- deskComCprngVar <$> getYesod
liftIO $ I.atomicModifyIORef var $
\g -> let (bs, g') = CPRNG.genRandomBytes 16 g
in (g', g' `seq` AES.IV bs)