module Yesod.Auth.Zendesk
( YesodZendesk(..)
, ZendeskUser(..)
, ZendeskExternalId(..)
, Zendesk
, getZendesk
, zendeskLoginRoute
) where
import Control.Applicative ((<$>))
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Default (Default(..))
import Data.List (intersperse)
import Data.Text (Text)
import Data.Time (getCurrentTime, formatTime)
import Language.Haskell.TH.Syntax (Pred(ClassP), Type(VarT), mkName)
import Yesod.Auth
import Yesod.Core
import qualified Crypto.Hash.MD5 as MD5
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Base16 as Base16
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
class YesodAuth master => YesodZendesk master where
zendeskToken :: master -> B.ByteString
zendeskAuthURL :: master -> Text
zendeskUserInfo :: GHandler Zendesk master ZendeskUser
data ZendeskUser =
ZendeskUser
{ zuName :: Text
, zuEmail :: Text
, zuExternalId :: ZendeskExternalId
, zuOrganization :: Maybe Text
, zuTags :: [Text]
, zuRemotePhotoURL :: Maybe Text
} deriving (Eq, Ord, Show, Read)
instance Default ZendeskUser where
def = ZendeskUser
{ zuName = error "ZendeskUser's zuName is a required field."
, zuEmail = error "ZendeskUser's zuEmail is a required field."
, zuExternalId = def
, zuOrganization = Nothing
, zuTags = []
, zuRemotePhotoURL = Nothing
}
data ZendeskExternalId =
UseYesodAuthId
| Explicit Text
| NoExternalId
deriving (Eq, Ord, Show, Read)
instance Default ZendeskExternalId where
def = UseYesodAuthId
data Zendesk = Zendesk
getZendesk :: a -> Zendesk
getZendesk = const Zendesk
mkYesodSub "Zendesk"
[ClassP ''YesodZendesk [VarT $ mkName "master"]]
[parseRoutes|
/ ZendeskLoginR GET
|]
zendeskLoginRoute :: Route Zendesk
zendeskLoginRoute = ZendeskLoginR
getZendeskLoginR :: YesodZendesk master => GHandler Zendesk master ()
getZendeskLoginR = do
(timestamp, getParams) <- do
rawReqParams <- W.queryString <$> waiRequest
case join $ lookup "timestamp" rawReqParams of
Nothing -> do
now <- liftIO getCurrentTime
let timestamp = B8.pack $ formatTime locale "%s" now
locale = error "yesod-auth-zendesk: never here (locale not needed)"
return (timestamp, [("timestamp", Just timestamp)])
Just timestamp ->
return (timestamp, rawReqParams)
ZendeskUser {..} <- zendeskUserInfo
externalId <- case zuExternalId of
UseYesodAuthId -> Just . toPathPiece <$> requireAuthId
Explicit x -> return (Just x)
NoExternalId -> return Nothing
let tags = T.concat $ intersperse "," zuTags
y <- getYesod
let hash =
let toBeHashed = B.concat . cons zuName
. cons zuEmail
. mcons externalId
. mcons zuOrganization
. cons tags
. mcons zuRemotePhotoURL
. (:) (zendeskToken y)
. (:) timestamp
$[]
cons = (:) . TE.encodeUtf8
mcons = maybe id cons
in Base16.encode $ MD5.hash toBeHashed
let addParams = paramT "name" (Just zuName)
. paramT "email" (Just zuEmail)
. paramBS "hash" (Just hash)
. paramT "external_id" externalId
. paramT "organization" zuOrganization
. paramT "tags" (Just tags)
. paramT "remote_photo_url" zuRemotePhotoURL
where
paramT name = paramBS name . fmap TE.encodeUtf8
paramBS name (Just t) | not (B.null t) = (:) (name, Just t)
paramBS _ _ = id
params = H.renderQuery True $
addParams getParams
redirect $ zendeskAuthURL y `T.append` TE.decodeUtf8 params