module Web.Slack.Experimental.RequestVerification
  ( SlackSigningSecret (..),
    SlackSignature (..),
    SlackRequestTimestamp (..),
    SlackVerificationFailed (..),
    validateRequest,
    validateRequest',
  )
where

import Crypto.Hash (SHA256, digestFromByteString)
import Crypto.MAC.HMAC
import Data.Aeson (eitherDecodeStrict)
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Char8 (readInt)
import Data.Either.Combinators (mapLeft, maybeToRight)
import Data.Time (NominalDiffTime)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Web.HttpApiData (FromHttpApiData (..))
import Web.Slack.Prelude

-- | Slack generated Signing Secret placed into configuration.
-- See https://api.slack.com/authentication/verifying-requests-from-slack#signing_secrets_admin_page
newtype SlackSigningSecret
  = SlackSigningSecret ByteString
  deriving stock (SlackSigningSecret -> SlackSigningSecret -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlackSigningSecret -> SlackSigningSecret -> Bool
$c/= :: SlackSigningSecret -> SlackSigningSecret -> Bool
== :: SlackSigningSecret -> SlackSigningSecret -> Bool
$c== :: SlackSigningSecret -> SlackSigningSecret -> Bool
Eq)

instance Show SlackSigningSecret where
  show :: SlackSigningSecret -> String
show SlackSigningSecret
_ = String
"<SlackSigningSecret>"

newtype SlackSignature = SlackSignature ByteString
  deriving newtype (SlackSignature -> SlackSignature -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlackSignature -> SlackSignature -> Bool
$c/= :: SlackSignature -> SlackSignature -> Bool
== :: SlackSignature -> SlackSignature -> Bool
$c== :: SlackSignature -> SlackSignature -> Bool
Eq, Int -> SlackSignature -> ShowS
[SlackSignature] -> ShowS
SlackSignature -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlackSignature] -> ShowS
$cshowList :: [SlackSignature] -> ShowS
show :: SlackSignature -> String
$cshow :: SlackSignature -> String
showsPrec :: Int -> SlackSignature -> ShowS
$cshowsPrec :: Int -> SlackSignature -> ShowS
Show)

newtype SlackRequestTimestamp = SlackRequestTimestamp ByteString
  deriving newtype (SlackRequestTimestamp -> SlackRequestTimestamp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlackRequestTimestamp -> SlackRequestTimestamp -> Bool
$c/= :: SlackRequestTimestamp -> SlackRequestTimestamp -> Bool
== :: SlackRequestTimestamp -> SlackRequestTimestamp -> Bool
$c== :: SlackRequestTimestamp -> SlackRequestTimestamp -> Bool
Eq, Int -> SlackRequestTimestamp -> ShowS
[SlackRequestTimestamp] -> ShowS
SlackRequestTimestamp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlackRequestTimestamp] -> ShowS
$cshowList :: [SlackRequestTimestamp] -> ShowS
show :: SlackRequestTimestamp -> String
$cshow :: SlackRequestTimestamp -> String
showsPrec :: Int -> SlackRequestTimestamp -> ShowS
$cshowsPrec :: Int -> SlackRequestTimestamp -> ShowS
Show)

instance FromHttpApiData SlackRequestTimestamp where
  parseQueryParam :: Text -> Either Text SlackRequestTimestamp
parseQueryParam Text
_ = forall a. HasCallStack => String -> a
error String
"SlackRequestTimestamp should not be in a query param"
  parseUrlPiece :: Text -> Either Text SlackRequestTimestamp
parseUrlPiece Text
_ = forall a. HasCallStack => String -> a
error String
"SlackRequestTimestamp should not be in a url piece"
  parseHeader :: ByteString -> Either Text SlackRequestTimestamp
parseHeader = forall a b. b -> Either a b
Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> SlackRequestTimestamp
SlackRequestTimestamp

instance FromHttpApiData SlackSignature where
  parseQueryParam :: Text -> Either Text SlackSignature
parseQueryParam Text
_ = forall a. HasCallStack => String -> a
error String
"SlackSignature should not be in a query param"
  parseUrlPiece :: Text -> Either Text SlackSignature
parseUrlPiece Text
_ = forall a. HasCallStack => String -> a
error String
"SlackSignature should not be in a url piece"
  parseHeader :: ByteString -> Either Text SlackSignature
parseHeader = forall a b. b -> Either a b
Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> SlackSignature
SlackSignature

data SlackVerificationFailed
  = VerificationMissingTimestamp
  | VerificationMalformedTimestamp ByteString
  | VerificationTimestampOutOfRange Int
  | VerificationMissingSignature
  | VerificationUnknownSignatureVersion ByteString
  | VerificationMalformedSignature String
  | VerificationUndecodableSignature ByteString
  | VerificationSignatureMismatch
  | VerificationCannotParse Text
  deriving stock (Int -> SlackVerificationFailed -> ShowS
[SlackVerificationFailed] -> ShowS
SlackVerificationFailed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlackVerificationFailed] -> ShowS
$cshowList :: [SlackVerificationFailed] -> ShowS
show :: SlackVerificationFailed -> String
$cshow :: SlackVerificationFailed -> String
showsPrec :: Int -> SlackVerificationFailed -> ShowS
$cshowsPrec :: Int -> SlackVerificationFailed -> ShowS
Show, SlackVerificationFailed -> SlackVerificationFailed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
$c/= :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
== :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
$c== :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
Eq)

instance Exception SlackVerificationFailed

validateRequest ::
  (MonadIO m, FromJSON a) =>
  SlackSigningSecret ->
  SlackSignature ->
  SlackRequestTimestamp ->
  ByteString ->
  m (Either SlackVerificationFailed a)
validateRequest :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
SlackSigningSecret
-> SlackSignature
-> SlackRequestTimestamp
-> ByteString
-> m (Either SlackVerificationFailed a)
validateRequest SlackSigningSecret
secret SlackSignature
sig SlackRequestTimestamp
reqTs ByteString
body =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \POSIXTime
time -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON a =>
POSIXTime
-> SlackSigningSecret
-> SlackSignature
-> SlackRequestTimestamp
-> ByteString
-> Either SlackVerificationFailed a
validateRequest' POSIXTime
time SlackSigningSecret
secret SlackSignature
sig SlackRequestTimestamp
reqTs ByteString
body

-- | Pure version of 'validateRequest'. Probably only useful for tests.
validateRequest' ::
  FromJSON a =>
  NominalDiffTime ->
  SlackSigningSecret ->
  SlackSignature ->
  SlackRequestTimestamp ->
  ByteString ->
  Either SlackVerificationFailed a
validateRequest' :: forall a.
FromJSON a =>
POSIXTime
-> SlackSigningSecret
-> SlackSignature
-> SlackRequestTimestamp
-> ByteString
-> Either SlackVerificationFailed a
validateRequest' POSIXTime
now (SlackSigningSecret ByteString
secret) (SlackSignature ByteString
sigHeader) (SlackRequestTimestamp ByteString
timestampString) ByteString
body = do
  let fiveMinutes :: POSIXTime
fiveMinutes = POSIXTime
5 forall a. Num a => a -> a -> a
* POSIXTime
60
  -- timestamp must be an Int for proper basestring construction below
  Int
timestamp <-
    forall b a. b -> Maybe a -> Either b a
maybeToRight (ByteString -> SlackVerificationFailed
VerificationMalformedTimestamp ByteString
timestampString) forall a b. (a -> b) -> a -> b
$
      forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Int, ByteString)
readInt ByteString
timestampString
  if forall a. Num a => a -> a
abs (POSIXTime
now forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timestamp) forall a. Ord a => a -> a -> Bool
> POSIXTime
fiveMinutes
    then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> SlackVerificationFailed
VerificationTimestampOutOfRange Int
timestamp
    else forall a b. b -> Either a b
Right ()
  ByteString
sigHeaderStripped <-
    forall b a. b -> Maybe a -> Either b a
maybeToRight (ByteString -> SlackVerificationFailed
VerificationUnknownSignatureVersion ByteString
sigHeader) forall a b. (a -> b) -> a -> b
$
      forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Maybe seq
stripPrefix ByteString
"v0=" ByteString
sigHeader
  ByteString
sigDecoded <-
    forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft String -> SlackVerificationFailed
VerificationMalformedSignature forall a b. (a -> b) -> a -> b
$
      ByteString -> Either String ByteString
B16.decode ByteString
sigHeaderStripped
  HMAC SHA256
sig :: HMAC SHA256 <-
    forall b a. b -> Maybe a -> Either b a
maybeToRight (ByteString -> SlackVerificationFailed
VerificationUndecodableSignature ByteString
sigDecoded) forall a b. (a -> b) -> a -> b
$
      forall a. Digest a -> HMAC a
HMAC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString ByteString
sigDecoded
  let basestring :: ByteString
basestring = forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text
"v0:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
timestamp forall a. Semigroup a => a -> a -> a
<> Text
":") forall a. Semigroup a => a -> a -> a
<> ByteString
body
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
secret ByteString
basestring forall a. Eq a => a -> a -> Bool
/= HMAC SHA256
sig) forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left SlackVerificationFailed
VerificationSignatureMismatch
  forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (Text -> SlackVerificationFailed
VerificationCannotParse forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall seq. IsSequence seq => [Element seq] -> seq
pack) forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
body