{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Crypto.Classical.Types
(
Cipher(..)
, Key(..)
, EnigmaKey(..)
, Rotor(..)
, Reflector
, Plugboard
, plugFrom
) where
import Crypto.Classical.Shuffle
import Crypto.Classical.Util
import Crypto.Number.Generate
import Crypto.Random (CPRG)
import Data.ByteString.Lazy (ByteString)
import Data.Char (isUpper)
import Data.List ((\\))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Modular
import Data.Text (Text)
class Key k => Cipher k a | a -> k where
encrypt :: k -> ByteString -> a ByteString
decrypt :: k -> ByteString -> a ByteString
class Key a where
key :: CPRG g => g -> a
instance Key (ℤ/26) where
key g = toMod . fst $ generateBetween g 1 25
instance Key (ℤ/26,ℤ/26) where
key g = (a, b)
where a = toMod . head $ shuffle g ([1,3..25] \\ [13]) 12
b = key g
instance Key (Map Char Char) where
key g = M.fromList $ zip ['A'..'Z'] $ shuffle g ['A'..'Z'] 26
instance Key [ℤ/26] where
key g = toMod n : key g'
where (n,g') = generateMax g 26
data Rotor = Rotor
{ _name :: Text
, _turnover :: ℤ/26
, _circuit :: Map (ℤ/26) (ℤ/26) }
deriving (Eq, Show)
rI :: Rotor
rI = Rotor "I" (int 'Q') . M.fromList $ map (both int) pairs
where
pairs :: [(Char, Char)]
pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "EKMFLGDQVZNTOWYHXUSPAIBRCJ"
rII :: Rotor
rII = Rotor "II" (int 'E') . M.fromList $ map (both int) pairs
where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "AJDKSIRUXBLHWTMCQGZNPYFVOE"
rIII :: Rotor
rIII = Rotor "III" (int 'V') . M.fromList $ map (both int) pairs
where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "BDFHJLCPRTXVZNYEIWGAKMUSQO"
rIV :: Rotor
rIV = Rotor "IV" (int 'J') . M.fromList $ map (both int) pairs
where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "ESOVPZJAYQUIRHXLNFTGKDCMWB"
rV :: Rotor
rV = Rotor "V" (int 'Z') . M.fromList $ map (both int) pairs
where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "VZBRGITYUPSDNHLXAWMJQOFECK"
type Reflector = Map (ℤ/26) (ℤ/26)
ukwB :: Reflector
ukwB = M.fromList $ map (both int) pairs
where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "YRUHQSLDPXNGOKMIEBFZCWVJAT"
type Plugboard = Map (ℤ/26) (ℤ/26)
data EnigmaKey = EnigmaKey
{ _rotors :: [Rotor]
, _settings :: String
, _reflector :: Reflector
, _plugboard :: Plugboard }
deriving (Eq, Show)
instance Key EnigmaKey where
key g = EnigmaKey rs ss ukwB $ randPlug g
where rn = 3
rs = take rn $ shuffle g [rI,rII,rIII,rIV,rV] 5
ss = randChars g rn
randChars :: CPRG g => g -> Int -> String
randChars _ 0 = []
randChars g n = letter (toMod c) : randChars g' (n-1)
where (c,g') = generateBetween g 0 25
randPlug :: CPRG g => g -> Plugboard
randPlug g = M.fromList (pairs <> singles)
where shuffled = shuffle g [0..25] 26
(ps,ss) = (take 20 shuffled, drop 20 shuffled)
pairs = foldr (\(k,v) acc -> (k,v) : (v,k) : acc) [] $ uniZip ps
singles = map (\v -> (v,v)) ss
plugFrom :: [(Char,Char)] -> Plugboard
plugFrom = f []
where f acc [] = let rest = stretch (['A'..'Z'] \\ acc) in
M.fromList . uniZip . map int $ acc ++ rest
f acc ((a,b):ps) | a `notElem` acc && b `notElem` acc &&
isUpper a && isUpper b = f (a : b : b : a : acc) ps
| otherwise = f acc ps