{-# LANGUAGE ForeignFunctionInterface #-}

-- |
-- Module      : Crypto.Cipher.DES.Primitive
-- License     : BSD-style
-- Stability   : experimental
-- Portability : Good
--
-- The DES block operation, as FIPS 46-3 defines it, over the C in
-- @cbits/crypton_des.c@.
--
-- A t'Schedule' holds the round keys of one or more stages in the order they
-- are applied, which is what lets single DES and the three stage constructions
-- share one entry point.
module Crypto.Cipher.DES.Primitive (
    Schedule,
    Direction (..),
    schedule,
    ecb,
) where

import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, Bytes)
import qualified Crypto.Internal.ByteArray as B
import Crypto.Internal.Compat (unsafeDoIO)
import Data.Word
import Foreign.C.Types (CInt (..))
import Foreign.Ptr (Ptr, plusPtr)

-- | Which way a stage runs.
data Direction = Encrypt | Decrypt
    deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Direction -> ShowS
showsPrec :: Int -> Direction -> ShowS
$cshow :: Direction -> String
show :: Direction -> String
$cshowList :: [Direction] -> ShowS
showList :: [Direction] -> ShowS
Show, Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
/= :: Direction -> Direction -> Bool
Eq)

-- | The round keys of one or more stages, in the order they are applied.
newtype Schedule = Schedule Bytes
    deriving (Schedule -> Schedule -> Bool
(Schedule -> Schedule -> Bool)
-> (Schedule -> Schedule -> Bool) -> Eq Schedule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Schedule -> Schedule -> Bool
== :: Schedule -> Schedule -> Bool
$c/= :: Schedule -> Schedule -> Bool
/= :: Schedule -> Schedule -> Bool
Eq)

-- | Bytes per stage: sixteen rounds of eight six-bit values.
stageSize :: Int
stageSize :: Int
stageSize = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8

-- | The block size DES works in.
blockBytes :: Int
blockBytes :: Int
blockBytes = Int
8

-- | Build the schedule for a sequence of stages, each an eight byte key and
-- the direction that stage runs in.  Shorter keys are rejected by the callers,
-- which know their own size; the bytes past the eighth are not read.
schedule :: ByteArrayAccess key => [(Direction, key)] -> Schedule
schedule :: forall key. ByteArrayAccess key => [(Direction, key)] -> Schedule
schedule [(Direction, key)]
stages =
    Bytes -> Schedule
Schedule (Bytes -> Schedule) -> Bytes -> Schedule
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Any -> IO ()) -> Bytes
forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
B.allocAndFreeze (Int
stageSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* [(Direction, key)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Direction, key)]
stages) ((Ptr Any -> IO ()) -> Bytes) -> (Ptr Any -> IO ()) -> Bytes
forall a b. (a -> b) -> a -> b
$ \Ptr Any
dst ->
        ((Int, (Direction, key)) -> IO ())
-> [(Int, (Direction, key))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Int -> (Direction, key) -> IO ())
-> (Int, (Direction, key)) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Ptr Any -> Int -> (Direction, key) -> IO ()
forall {ba} {a}.
ByteArrayAccess ba =>
Ptr a -> Int -> (Direction, ba) -> IO ()
one Ptr Any
dst)) ([Int] -> [(Direction, key)] -> [(Int, (Direction, key))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(Direction, key)]
stages)
  where
    one :: Ptr a -> Int -> (Direction, ba) -> IO ()
one Ptr a
dst Int
i (Direction
dir, ba
key) =
        ba -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
key ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
k ->
            Ptr Word8 -> Ptr Word8 -> CInt -> IO ()
c_des_init (Ptr a
dst Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stageSize)) Ptr Word8
k (Direction -> CInt
forall {a}. Num a => Direction -> a
reverseFlag Direction
dir)
    reverseFlag :: Direction -> a
reverseFlag Direction
Encrypt = a
0
    reverseFlag Direction
Decrypt = a
1

-- | Apply every stage of the schedule, in order, to each block of the input.
ecb :: ByteArray ba => Schedule -> ba -> ba
ecb :: forall ba. ByteArray ba => Schedule -> ba -> ba
ecb (Schedule Bytes
sched) ba
input
    | Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
blockBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 =
        String -> ba
forall a. HasCallStack => String -> a
error (String -> ba) -> String -> ba
forall a b. (a -> b) -> a -> b
$
            String
"Crypto.Cipher.DES: input length must be a multiple of block size (8). Its length is: "
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len
    | Bool
otherwise = IO ba -> ba
forall a. IO a -> a
unsafeDoIO (IO ba -> ba) -> IO ba -> ba
forall a b. (a -> b) -> a -> b
$
        Int -> (Ptr Word8 -> IO ()) -> IO ba
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc Int
len ((Ptr Word8 -> IO ()) -> IO ba) -> (Ptr Word8 -> IO ()) -> IO ba
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
out ->
            Bytes -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. Bytes -> (Ptr p -> IO a) -> IO a
B.withByteArray Bytes
sched ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ks ->
                ba -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
input ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
inp ->
                    Ptr Word8 -> Ptr Word8 -> Word32 -> Ptr Word8 -> Word32 -> IO ()
c_des_ecb
                        Ptr Word8
out
                        Ptr Word8
ks
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length Bytes
sched Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
stageSize))
                        Ptr Word8
inp
                        (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
blockBytes))
  where
    len :: Int
len = ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
input

foreign import ccall unsafe "crypton_des.h crypton_des_init"
    c_des_init :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()

foreign import ccall unsafe "crypton_des.h crypton_des_ecb"
    c_des_ecb :: Ptr Word8 -> Ptr Word8 -> Word32 -> Ptr Word8 -> Word32 -> IO ()