{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Auth.Zendesk
    ( YesodZendesk(..)
    , ZendeskUser(..)
    , ZendeskExternalId(..)
    , Zendesk
    , getZendesk
    , zendeskLoginRoute
    ) where

import Control.Applicative ((<$>))
import Control.Monad (join)
import Data.Default (Default(..))
import Data.List (intersperse)
import Data.Text (Text)
import Data.Time (getCurrentTime, formatTime)
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

import Yesod.Auth.Zendesk.Data


-- | Type class that you need to implement in order to support
-- Zendesk remote authentication.
--
-- /Minimal complete definition:/ all functions are required.
class YesodAuthPersist site => YesodZendesk site where
  -- | Shared secret between Zendesk and your site.
  zendeskToken :: site -> B.ByteString

  -- | URL on your Zendesk's site where users should be
  -- redirected to when logging in.
  zendeskAuthURL :: site -> Text

  -- | Gather information that should be given to Zendesk about
  -- an user.  Please see 'ZendeskUser' for more information
  -- about what these fields mean.
  --
  -- Simple example:
  --
  -- @
  -- zendeskUserInfo = do
  --   Entity uid user <- 'requireAuth'
  --   return 'def' { 'zuName'  = userName user
  --              , 'zuEmail' = userEmail user }
  -- @
  --
  -- Advanced example:
  --
  -- @
  -- zendeskUserInfo = do
  --   uid <- 'requireAuthId'
  --   render <- 'getUrlRender'
  --   runDB $ do
  --     Just user <- get uid
  --     Just org  <- get (userOrganization user)
  --     return 'def' { 'zuName'           = userName user
  --                , 'zuEmail'          = userEmail user
  --                , 'zuOrganization'   = Just (organizationName org)
  --                , 'zuRemotePhotoURL' = 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 Zendesk
  -- with some sort of guest user should the user not be logged
  -- in.
  zendeskUserInfo :: HandlerT site IO ZendeskUser


-- | Information about a user that is given to 'Zendesk'.  Please
-- see Zendesk's documentation
-- (<http://www.zendesk.com/support/api/remote-authentication>)
-- in order to see more details of how theses fields are
-- interpreted.
--
-- Only 'zuName' and 'zuEmail' are required.
data ZendeskUser =
  ZendeskUser
    { zuName :: Text
    -- ^ User name, at least two characters. (required)
    , zuEmail :: Text
    -- ^ E-mail address. (required)
    , zuExternalId :: ZendeskExternalId
    -- ^ An external (to Zendesk) ID that identifies this user.
    -- Defaults to 'UseYesodAuthId'.
    , zuOrganization :: Maybe Text
    -- ^ Organization the user belongs to.
    , zuTags :: [Text]
    -- ^ List of tags.
    , zuRemotePhotoURL :: Maybe Text
    -- ^ Public URL with the user's profile picture.
    } deriving (Eq, Ord, Show, Read)

-- | Fields 'zuName' and 'zuEmail' are required, so 'def' will be
-- 'undefined' for them.
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
          }


-- | Which external ID should be given to Zendesk.
data ZendeskExternalId =
    UseYesodAuthId
    -- ^ Use the user ID from @persistent@\'s database.  This is
    -- the recommended and default value.
  | Explicit Text
    -- ^ Use this given value.
  | NoExternalId
    -- ^ Do not give an external ID.
    deriving (Eq, Ord, Show, Read)

-- | Default is 'UseYesodAuthId'.
instance Default ZendeskExternalId where
  def = UseYesodAuthId


----------------------------------------------------------------------


-- | Create a new 'Zendesk', use this on your @config/routes@ file.
getZendesk :: a -> Zendesk
getZendesk = const Zendesk


instance YesodZendesk site => YesodSubDispatch Zendesk (HandlerT site IO) where
  yesodSubDispatch = $(mkYesodSubDispatch resourcesZendesk)


-- | Redirect the user to Zendesk such that they're already
-- logged in when they arrive.  For example, you may use
-- @zendeskLoginRoute@ when the user clicks on a \"Support\" item
-- on a menu.
zendeskLoginRoute :: Route Zendesk
zendeskLoginRoute = ZendeskLoginR


-- | Route used by the Zendesk remote authentication.  Works both
-- when Zendesk call us and when we call them.
getZendeskLoginR :: YesodZendesk site => HandlerT Zendesk (HandlerT site IO) ()
getZendeskLoginR = do
  -- Get the timestamp and the request params.
  (timestamp, getParams) <- do
    rawReqParams <- W.queryString <$> waiRequest
    case join $ lookup "timestamp" rawReqParams of
      Nothing -> do
        -- Doesn't seem to be a request from Zendesk, create our
        -- own timestamp.
        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 ->
        -- Seems to be a request from Zendesk.
        --
        -- They ask us to reply to them with all the request
        -- parameters they gave us, and at first it seems that
        -- this could create a security problem: we can't confirm
        -- that the request really came from Zendesk, and a
        -- malicious person could include a parameter such as
        -- "email=foo@bar.com".  These attacks would foiled by
        -- the hash, however.
        return (timestamp, rawReqParams)

  -- Get information about the currently logged user.
  ZendeskUser {..} <- lift zendeskUserInfo
  externalId <- case zuExternalId of
                  UseYesodAuthId -> Just . toPathPiece <$> lift requireAuthId
                  Explicit x     -> return (Just x)
                  NoExternalId   -> return Nothing
  let tags = T.concat $ intersperse "," zuTags

  -- Calculate hash
  y <- lift 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

  -- Encode information into parameters
  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 {- add question mark -} $
               addParams getParams

  -- Redirect to Zendesk
  redirect $ zendeskAuthURL y `T.append` TE.decodeUtf8 params