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
(SlackSigningSecret -> SlackSigningSecret -> Bool)
-> (SlackSigningSecret -> SlackSigningSecret -> Bool)
-> Eq SlackSigningSecret
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlackSigningSecret -> SlackSigningSecret -> Bool
== :: SlackSigningSecret -> SlackSigningSecret -> Bool
$c/= :: SlackSigningSecret -> SlackSigningSecret -> Bool
/= :: SlackSigningSecret -> SlackSigningSecret -> Bool
Eq)

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

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

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

instance FromHttpApiData SlackRequestTimestamp where
  parseQueryParam :: Text -> Either Text SlackRequestTimestamp
parseQueryParam Text
_ = String -> Either Text SlackRequestTimestamp
forall a. HasCallStack => String -> a
error String
"SlackRequestTimestamp should not be in a query param"
  parseUrlPiece :: Text -> Either Text SlackRequestTimestamp
parseUrlPiece Text
_ = String -> Either Text SlackRequestTimestamp
forall a. HasCallStack => String -> a
error String
"SlackRequestTimestamp should not be in a url piece"
  parseHeader :: ByteString -> Either Text SlackRequestTimestamp
parseHeader = SlackRequestTimestamp -> Either Text SlackRequestTimestamp
forall a b. b -> Either a b
Right (SlackRequestTimestamp -> Either Text SlackRequestTimestamp)
-> (ByteString -> SlackRequestTimestamp)
-> ByteString
-> Either Text SlackRequestTimestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
_ = String -> Either Text SlackSignature
forall a. HasCallStack => String -> a
error String
"SlackSignature should not be in a query param"
  parseUrlPiece :: Text -> Either Text SlackSignature
parseUrlPiece Text
_ = String -> Either Text SlackSignature
forall a. HasCallStack => String -> a
error String
"SlackSignature should not be in a url piece"
  parseHeader :: ByteString -> Either Text SlackSignature
parseHeader = SlackSignature -> Either Text SlackSignature
forall a b. b -> Either a b
Right (SlackSignature -> Either Text SlackSignature)
-> (ByteString -> SlackSignature)
-> ByteString
-> Either Text SlackSignature
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
(Int -> SlackVerificationFailed -> ShowS)
-> (SlackVerificationFailed -> String)
-> ([SlackVerificationFailed] -> ShowS)
-> Show SlackVerificationFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlackVerificationFailed -> ShowS
showsPrec :: Int -> SlackVerificationFailed -> ShowS
$cshow :: SlackVerificationFailed -> String
show :: SlackVerificationFailed -> String
$cshowList :: [SlackVerificationFailed] -> ShowS
showList :: [SlackVerificationFailed] -> ShowS
Show, SlackVerificationFailed -> SlackVerificationFailed -> Bool
(SlackVerificationFailed -> SlackVerificationFailed -> Bool)
-> (SlackVerificationFailed -> SlackVerificationFailed -> Bool)
-> Eq SlackVerificationFailed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
== :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
$c/= :: SlackVerificationFailed -> SlackVerificationFailed -> Bool
/= :: 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 =
  IO POSIXTime -> m POSIXTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime m POSIXTime
-> (POSIXTime -> m (Either SlackVerificationFailed a))
-> m (Either SlackVerificationFailed a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \POSIXTime
time -> Either SlackVerificationFailed a
-> m (Either SlackVerificationFailed a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SlackVerificationFailed a
 -> m (Either SlackVerificationFailed a))
-> Either SlackVerificationFailed a
-> m (Either SlackVerificationFailed a)
forall a b. (a -> b) -> a -> b
$ POSIXTime
-> SlackSigningSecret
-> SlackSignature
-> SlackRequestTimestamp
-> ByteString
-> Either SlackVerificationFailed a
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 POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
60
  -- timestamp must be an Int for proper basestring construction below
  Int
timestamp <-
    SlackVerificationFailed
-> Maybe Int -> Either SlackVerificationFailed Int
forall b a. b -> Maybe a -> Either b a
maybeToRight (ByteString -> SlackVerificationFailed
VerificationMalformedTimestamp ByteString
timestampString)
      (Maybe Int -> Either SlackVerificationFailed Int)
-> Maybe Int -> Either SlackVerificationFailed Int
forall a b. (a -> b) -> a -> b
$ (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst
      ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Int, ByteString)
readInt ByteString
timestampString
  if POSIXTime -> POSIXTime
forall a. Num a => a -> a
abs (POSIXTime
now POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timestamp) POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
fiveMinutes
    then SlackVerificationFailed -> Either SlackVerificationFailed ()
forall a b. a -> Either a b
Left (SlackVerificationFailed -> Either SlackVerificationFailed ())
-> SlackVerificationFailed -> Either SlackVerificationFailed ()
forall a b. (a -> b) -> a -> b
$ Int -> SlackVerificationFailed
VerificationTimestampOutOfRange Int
timestamp
    else () -> Either SlackVerificationFailed ()
forall a b. b -> Either a b
Right ()
  ByteString
sigHeaderStripped <-
    SlackVerificationFailed
-> Maybe ByteString -> Either SlackVerificationFailed ByteString
forall b a. b -> Maybe a -> Either b a
maybeToRight (ByteString -> SlackVerificationFailed
VerificationUnknownSignatureVersion ByteString
sigHeader)
      (Maybe ByteString -> Either SlackVerificationFailed ByteString)
-> Maybe ByteString -> Either SlackVerificationFailed ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Maybe seq
stripPrefix ByteString
"v0=" ByteString
sigHeader
  ByteString
sigDecoded <-
    (String -> SlackVerificationFailed)
-> Either String ByteString
-> Either SlackVerificationFailed ByteString
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft String -> SlackVerificationFailed
VerificationMalformedSignature
      (Either String ByteString
 -> Either SlackVerificationFailed ByteString)
-> Either String ByteString
-> Either SlackVerificationFailed ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B16.decode ByteString
sigHeaderStripped
  HMAC SHA256
sig :: HMAC SHA256 <-
    SlackVerificationFailed
-> Maybe (HMAC SHA256)
-> Either SlackVerificationFailed (HMAC SHA256)
forall b a. b -> Maybe a -> Either b a
maybeToRight (ByteString -> SlackVerificationFailed
VerificationUndecodableSignature ByteString
sigDecoded)
      (Maybe (HMAC SHA256)
 -> Either SlackVerificationFailed (HMAC SHA256))
-> Maybe (HMAC SHA256)
-> Either SlackVerificationFailed (HMAC SHA256)
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> HMAC SHA256
forall a. Digest a -> HMAC a
HMAC
      (Digest SHA256 -> HMAC SHA256)
-> Maybe (Digest SHA256) -> Maybe (HMAC SHA256)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Digest SHA256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString ByteString
sigDecoded
  let basestring :: ByteString
basestring = Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text
"v0:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
timestamp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
body
  Bool
-> Either SlackVerificationFailed ()
-> Either SlackVerificationFailed ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
secret ByteString
basestring HMAC SHA256 -> HMAC SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
/= HMAC SHA256
sig)
    (Either SlackVerificationFailed ()
 -> Either SlackVerificationFailed ())
-> Either SlackVerificationFailed ()
-> Either SlackVerificationFailed ()
forall a b. (a -> b) -> a -> b
$ SlackVerificationFailed -> Either SlackVerificationFailed ()
forall a b. a -> Either a b
Left SlackVerificationFailed
VerificationSignatureMismatch
  (String -> SlackVerificationFailed)
-> Either String a -> Either SlackVerificationFailed a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (Text -> SlackVerificationFailed
VerificationCannotParse (Text -> SlackVerificationFailed)
-> (String -> Text) -> String -> SlackVerificationFailed
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
[Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack) (Either String a -> Either SlackVerificationFailed a)
-> Either String a -> Either SlackVerificationFailed a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
body