module Network.Mail.SMTP.Auth (
    UserName,
    Password,
    Token,
    AuthType(..),
    encodeLogin,
    encodeLoginOAuth,
    auth,
) where

import Crypto.MAC.HMAC (hmac, HMAC)
import Crypto.Hash.Algorithms (MD5)
import Data.ByteArray (copyAndFreeze)
import qualified Data.ByteString.Base16 as B16  (encode)
import qualified Data.ByteString.Base64 as B64  (encode)

import Data.ByteString  (ByteString)
import Data.List
import qualified Data.ByteString       as B
import qualified Data.ByteString.Char8 as B8    (unwords)

type UserName = String
type Password = String
type Token = String

data AuthType
    = PLAIN
    | LOGIN
    | LOGIN_OAUTH
    | CRAM_MD5
    deriving AuthType -> AuthType -> Bool
(AuthType -> AuthType -> Bool)
-> (AuthType -> AuthType -> Bool) -> Eq AuthType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthType -> AuthType -> Bool
== :: AuthType -> AuthType -> Bool
$c/= :: AuthType -> AuthType -> Bool
/= :: AuthType -> AuthType -> Bool
Eq

instance Show AuthType where
    showsPrec :: Int -> AuthType -> ShowS
showsPrec Int
d AuthType
at = Bool -> ShowS -> ShowS
showParen (Int
dInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ AuthType -> String
showMain AuthType
at
        where app_prec :: Int
app_prec = Int
10
              showMain :: AuthType -> String
showMain AuthType
PLAIN       = String
"PLAIN"
              showMain AuthType
LOGIN       = String
"LOGIN"
              showMain AuthType
LOGIN_OAUTH = String
"XOAUTH2"
              showMain AuthType
CRAM_MD5    = String
"CRAM-MD5"

toAscii :: String -> ByteString
toAscii :: String -> ByteString
toAscii = [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a. Enum a => Int -> a
toEnum(Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
forall a. Enum a => a -> Int
fromEnum)

b64Encode :: String -> ByteString
b64Encode :: String -> ByteString
b64Encode = ByteString -> ByteString
B64.encode (ByteString -> ByteString)
-> (String -> ByteString) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toAscii

hmacMD5 :: ByteString -> ByteString -> ByteString
hmacMD5 :: ByteString -> ByteString -> ByteString
hmacMD5 ByteString
text ByteString
key =
    let mac :: HMAC MD5
mac = ByteString -> ByteString -> HMAC MD5
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
key ByteString
text :: HMAC MD5
    in HMAC MD5 -> (Ptr Any -> IO ()) -> ByteString
forall bs1 bs2 p.
(ByteArrayAccess bs1, ByteArray bs2) =>
bs1 -> (Ptr p -> IO ()) -> bs2
copyAndFreeze HMAC MD5
mac (IO () -> Ptr Any -> IO ()
forall a b. a -> b -> a
const (IO () -> Ptr Any -> IO ()) -> IO () -> Ptr Any -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

encodePlain :: UserName -> Password -> ByteString
encodePlain :: String -> String -> ByteString
encodePlain String
user String
pass = String -> ByteString
b64Encode (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\0" [String
user, String
user, String
pass]

encodeLogin :: UserName -> Password -> (ByteString, ByteString)
encodeLogin :: String -> String -> (ByteString, ByteString)
encodeLogin String
user String
pass = (String -> ByteString
b64Encode String
user, String -> ByteString
b64Encode String
pass)

-- | Encode the xoauth 2 message based on:
-- https://docs.microsoft.com/en-us/exchange/client-developer/legacy-protocols/how-to-authenticate-an-imap-pop-smtp-application-by-using-oauth#sasl-xoauth2
encodeLoginOAuth :: UserName -> Token -> ByteString
encodeLoginOAuth :: String -> String -> ByteString
encodeLoginOAuth String
user String
oauthToken =
  String -> ByteString
b64Encode (String
"user=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
user String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\x01" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"auth=Bearer " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
oauthToken String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\x01\x01")

cramMD5 :: String -> UserName -> Password -> ByteString
cramMD5 :: String -> String -> String -> ByteString
cramMD5 String
challenge String
user String
pass =
    ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B8.unwords [ByteString
user', ByteString -> ByteString
B16.encode (ByteString -> ByteString -> ByteString
hmacMD5 ByteString
challenge' ByteString
pass')]
  where
    challenge' :: ByteString
challenge' = String -> ByteString
toAscii String
challenge
    user' :: ByteString
user'      = String -> ByteString
toAscii String
user
    pass' :: ByteString
pass'      = String -> ByteString
toAscii String
pass

auth :: AuthType -> String -> UserName -> Password -> ByteString
auth :: AuthType -> String -> String -> String -> ByteString
auth AuthType
PLAIN       String
_ String
u String
p = String -> String -> ByteString
encodePlain String
u String
p
auth AuthType
LOGIN       String
_ String
u String
p = let (ByteString
u', ByteString
p') = String -> String -> (ByteString, ByteString)
encodeLogin String
u String
p in [ByteString] -> ByteString
B8.unwords [ByteString
u', ByteString
p']
auth AuthType
LOGIN_OAUTH String
_ String
u String
t = String -> String -> ByteString
encodeLoginOAuth String
u String
t
auth AuthType
CRAM_MD5    String
c String
u String
p = String -> String -> String -> ByteString
cramMD5 String
c String
u String
p