From 858bf6fe98401a853bb5141871888300cba779ea Mon Sep 17 00:00:00 2001
From: Stephen Paul Weber <singpolyma@singpolyma.net>
Date: Mon, 22 Jan 2024 11:27:00 -0500
Subject: [PATCH] Implement hash for sha1

---
 lib/Network/Protocol/TLS/GNU.hs                  | 13 ++++++++++++-
 .../Protocol/TLS/GNU/{Foreign.hs => Foreign.chs} | 16 +++++++++++++---
 2 files changed, 25 insertions(+), 4 deletions(-)
 rename lib/Network/Protocol/TLS/GNU/{Foreign.hs => Foreign.chs} (94%)

diff --git a/lib/Network/Protocol/TLS/GNU.hs b/lib/Network/Protocol/TLS/GNU.hs
index 711e263..cfab870 100644
--- a/lib/Network/Protocol/TLS/GNU.hs
+++ b/lib/Network/Protocol/TLS/GNU.hs
@@ -38,6 +38,8 @@ module Network.Protocol.TLS.GNU
 	, Credentials
 	, setCredentials
 	, certificateCredentials
+        , F.DigestAlgorithm(..)
+        , hash
 	) where
 
 import qualified Control.Concurrent.MVar as M
@@ -234,8 +236,17 @@ unsafeWithSession io = do
 	s <- getSession
 	UIO.unsafeFromIO $ F.withForeignPtr (sessionPtr s) $ io . F.Session
 
-checkRC :: (Monad m) => F.ReturnCode -> TLST m ()
+checkRC :: (Monad m) => F.ReturnCode -> E.ExceptT Error m ()
 checkRC (F.ReturnCode x) = when (x < 0) $ E.throwE $ mapError x
 
 mapError :: F.CInt -> Error
 mapError = Error . toInteger
+
+hash :: (Unexceptional m) => F.DigestAlgorithm -> B.ByteString -> E.ExceptT Error m B.ByteString
+hash algo input = E.ExceptT $ UIO.unsafeFromIO $ F.alloca $ \hashp -> F.alloca $ \output -> E.runExceptT $ do
+	checkRC =<< UIO.unsafeFromIO (F.gnutls_hash_init hashp (fromIntegral $ fromEnum algo))
+        hsh <- UIO.unsafeFromIO $ F.peek hashp
+	(checkRC =<<) $ UIO.unsafeFromIO $ B.unsafeUseAsCStringLen input $ \(cstr, len) ->
+		F.gnutls_hash hsh cstr (fromIntegral len)
+	UIO.unsafeFromIO $ F.gnutls_hash_deinit hsh output
+	UIO.unsafeFromIO $ B.unsafePackCString output
diff --git a/lib/Network/Protocol/TLS/GNU/Foreign.hs b/lib/Network/Protocol/TLS/GNU/Foreign.chs
similarity index 94%
rename from lib/Network/Protocol/TLS/GNU/Foreign.hs
rename to lib/Network/Protocol/TLS/GNU/Foreign.chs
index 28d1b9c..8461659 100644
--- a/lib/Network/Protocol/TLS/GNU/Foreign.hs
+++ b/lib/Network/Protocol/TLS/GNU/Foreign.chs
@@ -1,5 +1,7 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
+#include <gnutls/crypto.h>
+
 -- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
 --
 -- This program is free software: you can redistribute it and/or modify
@@ -40,9 +42,6 @@ newtype CredentialsType = CredentialsType CInt
 newtype MACAlgorithm = MACAlgorithm CInt
 	deriving (Show, Eq)
 
-newtype DigestAlgorithm = DigestAlgorithm CInt
-	deriving (Show, Eq)
-
 newtype CompressionMethod = CompressionMethod CInt
 	deriving (Show, Eq)
 
@@ -88,12 +87,15 @@ newtype PKAlgorithm = PKAlgorithm CInt
 newtype SignAlgorithm = SignAlgorithm CInt
 	deriving (Show, Eq)
 
+{#enum define DigestAlgorithm {GNUTLS_DIG_SHA1 as SHA1} deriving (Eq, Ord) #}
+
 newtype Credentials = Credentials (Ptr Credentials)
 newtype Transport = Transport (Ptr Transport)
 newtype Session = Session (Ptr Session)
 newtype DHParams = DHParams (Ptr DHParams)
 newtype RSAParams = RSAParams (Ptr RSAParams)
 newtype Priority = Priority (Ptr Priority)
+newtype Hash = Hash (Ptr Hash)
 
 newtype Datum = Datum (Ptr Word8, CUInt)
 
@@ -247,6 +249,14 @@ foreign import ccall "wrapper"
 
 -- }}}
 
+-- Crypto {{{
+
+foreign import ccall safe "gnutls_hash_init" gnutls_hash_init :: Ptr (Ptr Hash) -> CInt -> IO ReturnCode
+foreign import ccall safe "gnutls_hash" gnutls_hash :: Ptr Hash -> CString -> CSize -> IO ReturnCode
+foreign import ccall safe "gnutls_hash_deinit" gnutls_hash_deinit :: Ptr Hash -> CString -> IO ()
+
+-- }}}
+
 -- Utility {{{
 
 foreign import ccall safe "gnutls_global_set_mem_functions"
-- 
2.45.2