module OpenSSL.Utils
    ( failIfNull
    , failIfNull_
    , failIf
    , failIf_
    , raiseOpenSSLError
    , clearErrorStack
    , toHex
    , fromHex
    , peekCStringCLen
    )
    where
import Control.Monad
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import OpenSSL.ERR
import Data.Bits
import Data.List

failIfNull :: Ptr a -> IO (Ptr a)
failIfNull :: forall a. Ptr a -> IO (Ptr a)
failIfNull Ptr a
ptr
    = if Ptr a
ptr Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr then
          IO (Ptr a)
forall a. IO a
raiseOpenSSLError
      else
          Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr

failIfNull_ :: Ptr a -> IO ()
failIfNull_ :: forall a. Ptr a -> IO ()
failIfNull_ Ptr a
ptr
    = Ptr a -> IO (Ptr a)
forall a. Ptr a -> IO (Ptr a)
failIfNull Ptr a
ptr IO (Ptr a) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

failIf :: (a -> Bool) -> a -> IO a
failIf :: forall a. (a -> Bool) -> a -> IO a
failIf a -> Bool
f a
a
    | a -> Bool
f a
a       = IO a
forall a. IO a
raiseOpenSSLError
    | Bool
otherwise = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


failIf_ :: (a -> Bool) -> a -> IO ()
failIf_ :: forall a. (a -> Bool) -> a -> IO ()
failIf_ a -> Bool
f a
a
    = (a -> Bool) -> a -> IO a
forall a. (a -> Bool) -> a -> IO a
failIf a -> Bool
f a
a IO a -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


raiseOpenSSLError :: IO a
raiseOpenSSLError :: forall a. IO a
raiseOpenSSLError = IO CULong
getError IO CULong -> (CULong -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CULong -> IO String
errorString IO String -> (String -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail


clearErrorStack :: IO ()
clearErrorStack :: IO ()
clearErrorStack = do
  CULong
e <- IO CULong
getError
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CULong
e CULong -> CULong -> Bool
forall a. Eq a => a -> a -> Bool
/= CULong
0) IO ()
clearErrorStack

-- | Convert an integer to a hex string
toHex :: (Num i, Bits i) => i -> String
toHex :: forall i. (Num i, Bits i) => i -> String
toHex = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (i -> String) -> i -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> Char) -> [i] -> String
forall a b. (a -> b) -> [a] -> [b]
map i -> Char
forall {a}. (Eq a, Num a) => a -> Char
hexByte ([i] -> String) -> (i -> [i]) -> i -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> Maybe (i, i)) -> i -> [i]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr i -> Maybe (i, i)
forall {b}. (Num b, Bits b) => b -> Maybe (b, b)
step where
  step :: b -> Maybe (b, b)
step b
0 = Maybe (b, b)
forall a. Maybe a
Nothing
  step b
i = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
i b -> b -> b
forall a. Bits a => a -> a -> a
.&. b
0xf, b
i b -> Int -> b
forall a. Bits a => a -> Int -> a
`shiftR` Int
4)

  hexByte :: a -> Char
hexByte a
0 = Char
'0'
  hexByte a
1 = Char
'1'
  hexByte a
2 = Char
'2'
  hexByte a
3 = Char
'3'
  hexByte a
4 = Char
'4'
  hexByte a
5 = Char
'5'
  hexByte a
6 = Char
'6'
  hexByte a
7 = Char
'7'
  hexByte a
8 = Char
'8'
  hexByte a
9 = Char
'9'
  hexByte a
10 = Char
'a'
  hexByte a
11 = Char
'b'
  hexByte a
12 = Char
'c'
  hexByte a
13 = Char
'd'
  hexByte a
14 = Char
'e'
  hexByte a
15 = Char
'f'
  hexByte a
_  = Char
forall a. HasCallStack => a
undefined

-- | Convert a hex string to an integer
fromHex :: (Num i, Bits i) => String -> i
fromHex :: forall i. (Num i, Bits i) => String -> i
fromHex = (i -> Char -> i) -> i -> String -> i
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl i -> Char -> i
forall {a}. (Bits a, Num a) => a -> Char -> a
step i
0 where
  step :: a -> Char -> a
step a
acc Char
hexchar = (a
acc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) a -> a -> a
forall a. Bits a => a -> a -> a
.|. Char -> a
forall {a}. Num a => Char -> a
byteHex Char
hexchar

  byteHex :: Char -> a
byteHex Char
'0' = a
0
  byteHex Char
'1' = a
1
  byteHex Char
'2' = a
2
  byteHex Char
'3' = a
3
  byteHex Char
'4' = a
4
  byteHex Char
'5' = a
5
  byteHex Char
'6' = a
6
  byteHex Char
'7' = a
7
  byteHex Char
'8' = a
8
  byteHex Char
'9' = a
9
  byteHex Char
'a' = a
10
  byteHex Char
'b' = a
11
  byteHex Char
'c' = a
12
  byteHex Char
'd' = a
13
  byteHex Char
'e' = a
14
  byteHex Char
'f' = a
15
  byteHex Char
'A' = a
10
  byteHex Char
'B' = a
11
  byteHex Char
'C' = a
12
  byteHex Char
'D' = a
13
  byteHex Char
'E' = a
14
  byteHex Char
'F' = a
15
  byteHex Char
_   = a
forall a. HasCallStack => a
undefined

peekCStringCLen :: (Ptr CChar, CInt) -> IO String
peekCStringCLen :: (Ptr CChar, CInt) -> IO String
peekCStringCLen (Ptr CChar
p, CInt
n)
    = CStringLen -> IO String
peekCStringLen (Ptr CChar
p, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)