-- |
-- Module      : Crypto.System.CPU
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- Gives information about crypton runtime environment.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Crypto.System.CPU
    ( ProcessorOption (..)
    , processorOptions
    ) where

import Data.Data
import Data.List (findIndices)
#ifdef SUPPORT_RDRAND
import Data.Maybe (isJust)
#endif
import Data.Word (Word8)
import Foreign.Ptr
import Foreign.Storable

import Crypto.Internal.Compat

#ifdef SUPPORT_RDRAND
import Crypto.Random.Entropy.RDRand
import Crypto.Random.Entropy.Source
#endif

-- | CPU options impacting cryptography implementation and library performance.
data ProcessorOption
    = AESNI   -- ^ Support for AES instructions, with flag @support_aesni@
    | PCLMUL  -- ^ Support for CLMUL instructions, with flag @support_pclmuldq@
    | RDRAND  -- ^ Support for RDRAND instruction, with flag @support_rdrand@
    deriving (Int -> ProcessorOption -> ShowS
[ProcessorOption] -> ShowS
ProcessorOption -> String
(Int -> ProcessorOption -> ShowS)
-> (ProcessorOption -> String)
-> ([ProcessorOption] -> ShowS)
-> Show ProcessorOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProcessorOption -> ShowS
showsPrec :: Int -> ProcessorOption -> ShowS
$cshow :: ProcessorOption -> String
show :: ProcessorOption -> String
$cshowList :: [ProcessorOption] -> ShowS
showList :: [ProcessorOption] -> ShowS
Show,ProcessorOption -> ProcessorOption -> Bool
(ProcessorOption -> ProcessorOption -> Bool)
-> (ProcessorOption -> ProcessorOption -> Bool)
-> Eq ProcessorOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProcessorOption -> ProcessorOption -> Bool
== :: ProcessorOption -> ProcessorOption -> Bool
$c/= :: ProcessorOption -> ProcessorOption -> Bool
/= :: ProcessorOption -> ProcessorOption -> Bool
Eq,Int -> ProcessorOption
ProcessorOption -> Int
ProcessorOption -> [ProcessorOption]
ProcessorOption -> ProcessorOption
ProcessorOption -> ProcessorOption -> [ProcessorOption]
ProcessorOption
-> ProcessorOption -> ProcessorOption -> [ProcessorOption]
(ProcessorOption -> ProcessorOption)
-> (ProcessorOption -> ProcessorOption)
-> (Int -> ProcessorOption)
-> (ProcessorOption -> Int)
-> (ProcessorOption -> [ProcessorOption])
-> (ProcessorOption -> ProcessorOption -> [ProcessorOption])
-> (ProcessorOption -> ProcessorOption -> [ProcessorOption])
-> (ProcessorOption
    -> ProcessorOption -> ProcessorOption -> [ProcessorOption])
-> Enum ProcessorOption
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ProcessorOption -> ProcessorOption
succ :: ProcessorOption -> ProcessorOption
$cpred :: ProcessorOption -> ProcessorOption
pred :: ProcessorOption -> ProcessorOption
$ctoEnum :: Int -> ProcessorOption
toEnum :: Int -> ProcessorOption
$cfromEnum :: ProcessorOption -> Int
fromEnum :: ProcessorOption -> Int
$cenumFrom :: ProcessorOption -> [ProcessorOption]
enumFrom :: ProcessorOption -> [ProcessorOption]
$cenumFromThen :: ProcessorOption -> ProcessorOption -> [ProcessorOption]
enumFromThen :: ProcessorOption -> ProcessorOption -> [ProcessorOption]
$cenumFromTo :: ProcessorOption -> ProcessorOption -> [ProcessorOption]
enumFromTo :: ProcessorOption -> ProcessorOption -> [ProcessorOption]
$cenumFromThenTo :: ProcessorOption
-> ProcessorOption -> ProcessorOption -> [ProcessorOption]
enumFromThenTo :: ProcessorOption
-> ProcessorOption -> ProcessorOption -> [ProcessorOption]
Enum,Typeable ProcessorOption
Typeable ProcessorOption =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> ProcessorOption -> c ProcessorOption)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ProcessorOption)
-> (ProcessorOption -> Constr)
-> (ProcessorOption -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ProcessorOption))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ProcessorOption))
-> ((forall b. Data b => b -> b)
    -> ProcessorOption -> ProcessorOption)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> ProcessorOption -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ProcessorOption -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> ProcessorOption -> m ProcessorOption)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ProcessorOption -> m ProcessorOption)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> ProcessorOption -> m ProcessorOption)
-> Data ProcessorOption
ProcessorOption -> Constr
ProcessorOption -> DataType
(forall b. Data b => b -> b) -> ProcessorOption -> ProcessorOption
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ProcessorOption -> u
forall u. (forall d. Data d => d -> u) -> ProcessorOption -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ProcessorOption
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ProcessorOption -> c ProcessorOption
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ProcessorOption)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ProcessorOption)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ProcessorOption -> c ProcessorOption
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ProcessorOption -> c ProcessorOption
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ProcessorOption
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ProcessorOption
$ctoConstr :: ProcessorOption -> Constr
toConstr :: ProcessorOption -> Constr
$cdataTypeOf :: ProcessorOption -> DataType
dataTypeOf :: ProcessorOption -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ProcessorOption)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ProcessorOption)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ProcessorOption)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ProcessorOption)
$cgmapT :: (forall b. Data b => b -> b) -> ProcessorOption -> ProcessorOption
gmapT :: (forall b. Data b => b -> b) -> ProcessorOption -> ProcessorOption
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ProcessorOption -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ProcessorOption -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ProcessorOption -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ProcessorOption -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ProcessorOption -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ProcessorOption -> m ProcessorOption
Data)

-- | Options which have been enabled at compile time and are supported by the
-- current CPU.
processorOptions :: [ProcessorOption]
processorOptions :: [ProcessorOption]
processorOptions = IO [ProcessorOption] -> [ProcessorOption]
forall a. IO a -> a
unsafeDoIO (IO [ProcessorOption] -> [ProcessorOption])
-> IO [ProcessorOption] -> [ProcessorOption]
forall a b. (a -> b) -> a -> b
$ do
    Ptr Word8
p <- IO (Ptr Word8)
crypton_aes_cpu_init
    [Word8]
options <- (ProcessorOption -> IO Word8) -> [ProcessorOption] -> IO [Word8]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Ptr Word8 -> ProcessorOption -> IO Word8
forall {a} {a}. (Storable a, Enum a) => Ptr a -> a -> IO a
getOption Ptr Word8
p) [ProcessorOption]
aesOptions
    Bool
rdrand  <- IO Bool
hasRDRand
    [ProcessorOption] -> IO [ProcessorOption]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word8] -> [ProcessorOption]
decodeOptions [Word8]
options [ProcessorOption] -> [ProcessorOption] -> [ProcessorOption]
forall a. [a] -> [a] -> [a]
++ [ ProcessorOption
RDRAND | Bool
rdrand ])
  where
    aesOptions :: [ProcessorOption]
aesOptions    = [ ProcessorOption
AESNI .. ProcessorOption
PCLMUL ]
    getOption :: Ptr a -> a -> IO a
getOption Ptr a
p   = Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
p (Int -> IO a) -> (a -> Int) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum
    decodeOptions :: [Word8] -> [ProcessorOption]
decodeOptions = (Int -> ProcessorOption) -> [Int] -> [ProcessorOption]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ProcessorOption
forall a. Enum a => Int -> a
toEnum ([Int] -> [ProcessorOption])
-> ([Word8] -> [Int]) -> [Word8] -> [ProcessorOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> [Word8] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0)
{-# NOINLINE processorOptions #-}

hasRDRand :: IO Bool
#ifdef SUPPORT_RDRAND
hasRDRand :: IO Bool
hasRDRand = (Maybe RDRand -> Bool) -> IO (Maybe RDRand) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe RDRand -> Bool
forall a. Maybe a -> Bool
isJust IO (Maybe RDRand)
getRDRand
  where getRDRand :: IO (Maybe RDRand)
getRDRand = IO (Maybe RDRand)
forall a. EntropySource a => IO (Maybe a)
entropyOpen :: IO (Maybe RDRand)
#else
hasRDRand = return False
#endif

foreign import ccall unsafe "crypton_aes_cpu_init"
    crypton_aes_cpu_init :: IO (Ptr Word8)