crypto-classical (empty) → 0.0.1
raw patch · 16 files changed
+943/−0 lines, 16 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, containers, crypto-numbers, crypto-random, lens, modular-arithmetic, random, random-shuffle, text, transformers
Files
- Crypto/Classical.hs +23/−0
- Crypto/Classical/Cipher.hs +23/−0
- Crypto/Classical/Cipher/Affine.hs +52/−0
- Crypto/Classical/Cipher/Caesar.hs +48/−0
- Crypto/Classical/Cipher/Enigma.hs +82/−0
- Crypto/Classical/Cipher/Stream.hs +55/−0
- Crypto/Classical/Cipher/Substitution.hs +44/−0
- Crypto/Classical/Cipher/Vigenere.hs +46/−0
- Crypto/Classical/Letter.hs +23/−0
- Crypto/Classical/Shuffle.hs +80/−0
- Crypto/Classical/Test.hs +94/−0
- Crypto/Classical/Types.hs +180/−0
- Crypto/Classical/Util.hs +90/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- crypto-classical.cabal +71/−0
+ Crypto/Classical.hs view
@@ -0,0 +1,23 @@+-- |+-- Module : Crypto.Classical+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++-- A reexport of every module.++module Crypto.Classical+ ( module Crypto.Classical.Cipher+ , module Crypto.Classical.Letter+ , module Crypto.Classical.Shuffle+ , module Crypto.Classical.Test+ , module Crypto.Classical.Types+ , module Crypto.Classical.Util+ ) where++import Crypto.Classical.Cipher+import Crypto.Classical.Letter+import Crypto.Classical.Shuffle+import Crypto.Classical.Test+import Crypto.Classical.Types+import Crypto.Classical.Util
+ Crypto/Classical/Cipher.hs view
@@ -0,0 +1,23 @@+-- |+-- Module : Crypto.Classical+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++-- A reexport of every Cipher module.++module Crypto.Classical.Cipher+ ( module Crypto.Classical.Cipher.Affine+ , module Crypto.Classical.Cipher.Caesar+ , module Crypto.Classical.Cipher.Enigma+ , module Crypto.Classical.Cipher.Stream+ , module Crypto.Classical.Cipher.Substitution+ , module Crypto.Classical.Cipher.Vigenere+ ) where++import Crypto.Classical.Cipher.Affine+import Crypto.Classical.Cipher.Caesar+import Crypto.Classical.Cipher.Enigma+import Crypto.Classical.Cipher.Stream+import Crypto.Classical.Cipher.Substitution+import Crypto.Classical.Cipher.Vigenere
+ Crypto/Classical/Cipher/Affine.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Crypto.Classical.Affine+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Cipher.Affine where++import Control.Lens+import Crypto.Classical.Types+import Crypto.Classical.Util+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Char+import Data.Modular++---++-- | An Affine Cipher is a non-random Substitution Cipher, such that a+-- character `x` is mapped to a cipher character according to the equation:+--+-- f(x) = ax + b (mod 26)+--+-- Also known as a Linear Cipher.+newtype Affine a = Affine { _affine :: a } deriving (Eq,Show,Functor)+makeLenses ''Affine++instance Applicative Affine where+ pure = Affine+ Affine f <*> Affine a = Affine $ f a++instance Monad Affine where+ return = pure+ Affine a >>= f = f a++instance Cipher (ℤ/26,ℤ/26) Affine where+ encrypt (a,b) = pure . B.map f+ where f c | isLower c = f $ toUpper c+ | not $ isLetter c = c+ | otherwise = letter $ a * int c + b++ decrypt (a,b) = pure . B.map f+ where f c | isLower c = f $ toUpper c+ | not $ isLetter c = c+ | otherwise = letter $ (int c - b) * inverse a
+ Crypto/Classical/Cipher/Caesar.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Module : Crypto.Classical.Caesar+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Cipher.Caesar where++import Control.Lens+import Crypto.Classical.Types+import Crypto.Classical.Util+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Char+import Data.Modular++---++-- | A simple Shift Cipher. The key is a number by which to shift each+-- letter in the alphabet. Example:+--+-- >>> encrypt 3 "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ^. caesar+-- "DEFGHIJKLMNOPQRSTUVWXYZABC"+newtype Caesar a = Caesar { _caesar :: a } deriving (Eq,Show,Functor)+makeLenses ''Caesar++instance Applicative Caesar where+ pure = Caesar+ Caesar f <*> Caesar a = Caesar $ f a++instance Monad Caesar where+ return = pure+ Caesar a >>= f = f a++instance Cipher (ℤ/26) Caesar where+ encrypt k = pure . B.map f+ where f c | isLower c = f $ toUpper c+ | not $ isLetter c = c+ | otherwise = letter $ int c + k++ decrypt k = encrypt (-k)
+ Crypto/Classical/Cipher/Enigma.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Crypto.Classical.Cipher.Enigma+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Cipher.Enigma where++import Control.Lens+import Control.Monad.Trans.State.Lazy+import Crypto.Classical.Types+import Crypto.Classical.Util+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Char+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as M+import Data.Maybe (fromJust)+import Data.Modular++---++newtype Enigma a = Enigma { _enigma :: a } deriving (Eq,Show,Functor)+makeLenses ''Enigma++instance Applicative Enigma where+ pure = Enigma+ Enigma f <*> Enigma a = Enigma $ f a++instance Monad Enigma where+ return = pure+ Enigma a >>= f = f a++-- | When a machine operator presses a key, the Rotors rotate.+-- A circuit is then completed as they hold the key down, and a bulb+-- is lit. Here, we make sure to rotate the Rotors before encrypting+-- the character.+-- NOTE: Decryption is the same as encryption.+instance Cipher EnigmaKey Enigma where+ decrypt = encrypt+ encrypt k m = pure . B.pack $ evalState (traverse f $ B.unpack m) k'+ where k' = withInitPositions k+ f c | not $ isLetter c = return c+ | isLower c = f $ toUpper c+ | otherwise = do+ modify (& rotors %~ turn)+ (EnigmaKey rots _ rl pl) <- get+ let rs = rots ^.. traverse . circuit+ rs' = reverse $ map mapInverse rs+ pl' = mapInverse pl+ cmp = foldl1 compose+ e = pl |.| cmp rs |.| rl |.| cmp rs' |.| pl'+ return . letter . fromJust . flip M.lookup e $ int c++-- | Applies the initial Rotor settings as defined in the Key to+-- the Rotors themselves. These initial rotations do not trigger+-- the turnover of neighbouring Rotors as usual.+withInitPositions :: EnigmaKey -> EnigmaKey+withInitPositions k = k & rotors .~ zipWith f (k ^. rotors) (k ^. settings)+ where f r s = (r & circuit %~ rotate (int s)+ & turnover -~ (int s))++-- | Turn the (machine's) right-most (left-most in List) Rotor by one+-- position. If its turnover value wraps back to 25, then turn the next+-- Rotor as well.+turn :: [Rotor] -> [Rotor]+turn [] = []+turn (r:rs) = if (r' ^. turnover) == 25 then r' : turn rs else r' : rs+ where r' = r & circuit %~ rotate 1 & turnover -~ 1++-- | Rotate a Rotor by `n` positions. By subtracting 1 from every key+-- and value, we perfectly simulate rotation. Example:+--+-- >>> rotate $ M.fromList [(0,2),(1,0),(2,3),(3,4),(4,1)]+-- M.fromList [(4,1),(0,4),(1,2),(2,3),(3,0)]+rotate :: ℤ/26 -> Map (ℤ/26) (ℤ/26) -> Map (ℤ/26) (ℤ/26)+rotate n r = M.fromList (itoList r & traverse . both -~ n)
+ Crypto/Classical/Cipher/Stream.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Module : Crypto.Classical.Stream+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Cipher.Stream where++import Control.Lens+import Crypto.Classical.Types+import Crypto.Classical.Util+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Char+import Data.Modular++---++-- | A Cipher with pseudorandom keys as long as the plaintext.+-- Since Haskell is lazy, our keys here are actually of infinite length.+--+-- If for whatever reason a key of finite length is given to `encrypt`,+-- the ciphertext is cutoff to match the key length. Example:+--+-- >>> encrypt [1,2,3] "ABCDEF" ^. stream+-- "BDF"+newtype Stream a = Stream { _stream :: a } deriving (Eq,Show,Functor)+makeLenses ''Stream++instance Applicative Stream where+ pure = Stream+ Stream f <*> Stream a = Stream $ f a++instance Monad Stream where+ return = pure+ Stream a >>= f = f a++instance Cipher [ℤ/26] Stream where+ encrypt k = pure . B.pack . f k . B.unpack+ where f _ [] = []+ f [] _ = []+ f (kc:ks) (m:ms) + | isLower m = f (kc:ks) (toUpper m : ms)+ | not $ isLetter m = m : f ks ms+ | otherwise = letter (int m + kc) : f ks ms++ decrypt k = encrypt k'+ where k' = map (* (-1)) k
+ Crypto/Classical/Cipher/Substitution.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Crypto.Classical.Substitution+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Cipher.Substitution where++import Control.Lens+import Crypto.Classical.Types+import Crypto.Classical.Util+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Char+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as M++---++-- | A Cipher whose key is a (pseudo)random mapping of characters+-- to other characters. A character may map to itself.+newtype Substitution a = Substitution { _substitution :: a }+ deriving (Eq,Show,Functor)+makeLenses ''Substitution++instance Applicative Substitution where+ pure = Substitution+ Substitution f <*> Substitution a = Substitution $ f a++instance Monad Substitution where+ return = pure+ Substitution a >>= f = f a++instance Cipher (Map Char Char) Substitution where+ encrypt m = pure . B.map f+ where f c | isLower c = f $ toUpper c+ | otherwise = M.findWithDefault c c m++ decrypt m = encrypt (mapInverse m)
+ Crypto/Classical/Cipher/Vigenere.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Crypto.Classical.Vigenere+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Cipher.Vigenere where++import Control.Lens+import Crypto.Classical.Cipher.Stream+import Crypto.Classical.Types+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Modular++---++-- | A Vigenère Cipher is just a Stream Cipher with a finite key,+-- shorter than the length of the plaintext. The key is repeated for+-- the entire length of the plaintext.+newtype Vigenère a = Vigenère { _vigenère :: a } deriving (Eq,Show,Functor)+makeLenses ''Vigenère++instance Applicative Vigenère where+ pure = Vigenère+ Vigenère f <*> Vigenère a = Vigenère $ f a++instance Monad Vigenère where+ return = pure+ Vigenère a >>= f = f a++instance Cipher [ℤ/26] Vigenère where+ encrypt k m = pure . view stream . encrypt (vigKey m k) $ m+ decrypt k m = pure . view stream . decrypt (vigKey m k) $ m++-- | Determine a Vigenère key from a Stream key.+-- Weakness here: key length is a factor of the plaintext length.+vigKey :: B.ByteString -> [ℤ/26] -> [ℤ/26]+vigKey m k = concat . repeat . take (n+1) $ k+ where n = floor . logBase 2 . fromIntegral . B.length $ m
+ Crypto/Classical/Letter.hs view
@@ -0,0 +1,23 @@+module Crypto.Classical.Letter where++-- |+-- Module : Crypto.Classical.Letter+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++import Data.Char+import Test.QuickCheck++---++-- | A `Letter` is a capital Ascii letter (A-Z)+data Letter = Letter { _char :: Char } deriving (Eq,Show)++instance Arbitrary Letter where+ arbitrary = Letter <$> c+ where c = do+ c' <- arbitrary+ if isAsciiUpper c'+ then return c'+ else c
+ Crypto/Classical/Shuffle.hs view
@@ -0,0 +1,80 @@+-- Code borrowed from `random-shuffle` and modified to match+-- crypto-random data types.++-- |+-- Module : Crypto.Classical.Shuffle+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Shuffle+ (+ -- * List Scrambling+ shuffle+ ) where++import Crypto.Classical.Util+import Crypto.Random+import Data.Function (fix)++---++-- A complete binary tree, of leaves and internal nodes.+-- Internal node: Node card l r+-- where card is the number of leaves under the node.+-- Invariant: card >=2. All internal tree nodes are always full.+data Tree a = Leaf !a+ | Node !Integer !(Tree a) !(Tree a)+ deriving Show++-- Convert a sequence (e1...en) to a complete binary tree+buildTree :: [a] -> Tree a+buildTree = (fix growLevel) . (map Leaf)+ where growLevel _ [node] = node+ growLevel self l = self $ inner l++ inner [] = []+ inner [e] = [e]+ inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es++ join l@(Leaf _) r@(Leaf _) = Node 2 l r+ join l@(Node ct _ _) r@(Leaf _) = Node (ct + 1) l r+ join l@(Leaf _) r@(Node ct _ _) = Node (ct + 1) l r+ join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl + ctr) l r++-- | Given a sequence (e1,...en) to shuffle, its length, and a random+-- generator, compute the corresponding permutation of the input+-- sequence.+shuffle :: CPRG g => g -> [a] -> Integer -> [a]+shuffle g elements = shuffle' elements . rseq g++-- | Given a sequence (e1,...en) to shuffle, and a sequence+-- (r1,...r[n-1]) of numbers such that r[i] is an independent sample+-- from a uniform random distribution [0..n-i], compute the+-- corresponding permutation of the input sequence.+shuffle' :: [a] -> [Integer] -> [a]+shuffle' elements = shuffleTree (buildTree elements)+ where shuffleTree (Leaf e) [] = [e]+ shuffleTree tree (r : rs) =+ let (b, rest) = extractTree r tree+ in b : (shuffleTree rest rs)+ shuffleTree _ _ = error "[shuffle] called with lists of different lengths"++ -- Extracts the n-th element from the tree and returns+ -- that element, paired with a tree with the element+ -- deleted.+ -- The function maintains the invariant of the completeness+ -- of the tree: all internal nodes are always full.+ extractTree 0 (Node _ (Leaf e) r) = (e, r)+ extractTree 1 (Node 2 (Leaf l) (Leaf r)) = (r, Leaf l)+ extractTree n (Node c (Leaf l) r) =+ let (e, r') = extractTree (n - 1) r+ in (e, Node (c - 1) (Leaf l) r')+ extractTree n (Node n' l (Leaf e))+ | n + 1 == n' = (e, l)+ extractTree n (Node c l@(Node cl _ _) r)+ | n < cl = let (e, l') = extractTree n l+ in (e, Node (c - 1) l' r)+ | otherwise = let (e, r') = extractTree (n - cl) r+ in (e, Node (c - 1) l r')+ extractTree _ _ = error "[extractTree] impossible"
+ Crypto/Classical/Test.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Crypto.Classical.Test+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Test+ (+ -- * Single Tests+ cycleT+ , notSelfT+ -- * Batch Tests+ , testAll+ ) where++import Control.Lens+import Control.Monad (void)+import Crypto.Classical.Cipher+import Crypto.Classical.Letter+import Crypto.Classical.Types+import Crypto.Classical.Util (prng)+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as B+import Test.QuickCheck++---++-- Not to be exported, as this only generates ByteStrings+-- of capital Ascii characters.+instance Arbitrary ByteString where+ arbitrary = B.pack . map _char <$> arbitrary++---++-- | Run every test on every Cipher.+testAll :: IO ()+testAll = void $ sequence [ cycleT $ view caesar+ , cycleT $ view affine+ , cycleT $ view substitution+ , cycleT $ view stream+ , cycleT $ view vigenère+ , cycleT $ view enigma+ , notSelfT $ view caesar+ , notSelfT $ view affine+ , notSelfT $ view substitution+ , notSelfT $ view stream+ , notSelfT $ view vigenère+ , notSelfT $ view enigma+ , diffKeyT $ view caesar+ , diffKeyT $ view affine+ , diffKeyT $ view substitution+ , diffKeyT $ view stream+ , diffKeyT $ view vigenère+ , diffKeyT $ view enigma+ , noSelfMappingT+ ]++-- | An encrypted message should decrypt to the original plaintext.+cycleT :: (Monad c, Cipher k c) => (c ByteString -> ByteString) -> IO ()+cycleT f = do+ k <- key <$> prng+ quickCheck (\m -> f (encrypt k m >>= decrypt k) == m)++-- | A message should never encrypt to itself.+notSelfT :: (Monad c, Cipher k c) => (c ByteString -> ByteString) -> IO ()+notSelfT f = do+ k <- key <$> prng+ quickCheck (\m -> B.length m > 1 ==> m /= e f k m)++-- | Different keys should yield different encryptions.+diffKeyT :: (Eq k,Monad c,Cipher k c) => (c ByteString -> ByteString) -> IO ()+diffKeyT f = do+ k <- key <$> prng+ k' <- key <$> prng+ quickCheck (\m -> k /= k' && B.length m > 1 ==> e f k m /= e f k' m)++-- | A letter can never encrypt to itself.+noSelfMappingT :: IO ()+noSelfMappingT = do+ k <- key <$> prng+ quickCheck (\m -> all (\(a,b) -> a /= b) $ B.zip m (e _enigma k m))++-- | Encrypt and unwrap a message.+e :: Cipher k a => (a ByteString -> t) -> k -> ByteString -> t+e f k m = f $ encrypt k m++-- | A small manual test of Enigma.+enig :: IO ByteString+enig = do+ k <- key <$> prng+ return $ encrypt k "Das ist ein Wetterbericht. Heil Hitler." ^. enigma
+ Crypto/Classical/Types.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Module : Crypto.Classical.Types+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Types+ (+ -- * Cipher+ Cipher(..)+ -- * Keys+ , Key(..)+ -- * Enigma Types+ , EnigmaKey(..)+ , Rotor(..)+ , Reflector+ , Plugboard+ , name+ , turnover+ , circuit+ , rotors+ , settings+ , reflector+ , plugboard+ ) where++import Control.Lens+import Crypto.Classical.Shuffle+import Crypto.Classical.Util+import Crypto.Number.Generate+import Crypto.Random (CPRG)+import Data.ByteString.Lazy (ByteString)+import Data.List ((\\))+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as M+import Data.Modular+import Data.Monoid ((<>))+import Data.Text (Text)++---++-- | A Cipher must be able to encrypt and decrypt. The Cipher type+-- determines the Key type.+class Key k => Cipher k a | a -> k where+ encrypt :: k -> ByteString -> a ByteString+ decrypt :: k -> ByteString -> a ByteString++-- | Keys can appear in a number of different forms.+-- E.g. a single number, a tuple, a mapping, etc.+-- Each needs to be interpreted uniquely by a Cipher's+-- `encrypt` and `decrypt` algorithms.+class Key a where+ -- | Randomly generate a Key.+ key :: CPRG g => g -> a++instance Key (ℤ/26) where+ key g = toMod . fst $ generateBetween g 1 25++-- | For Affine Ciphers.+-- `a` must be coprime with 26, or else a^-1 won't exist and+-- and we can't decrypt.+instance Key (ℤ/26,ℤ/26) where+ key g = (a,b) & _1 %~ toMod+ where a = head $ shuffle g ([1,3..25] \\ [13]) 12+ b = key g++-- | Key for Substitution Cipher. The Key is the Mapping itself.+instance Key (Map Char Char) where+ key g = M.fromList $ zip ['A'..'Z'] $ shuffle g ['A'..'Z'] 26++-- | Key for Stream/Vigenère Cipher.+instance Key [ℤ/26] where+ key g = n : key g'+ where (n,g') = generateMax g 26 & _1 %~ toMod++---++-- | A Rotor (German: Walze) is a wheel labelled A to Z, with internal+-- wirings from each entry point to exit point. There is also a turnover+-- point, upon which a Rotor would turn its left neighbour as well.+-- Typically said turnover point is thought of in terms of letters+-- (e.g. Q->R for Rotor I). Here, we represent the turnover point as+-- a distance from A (or 0, the first entry point). As the Rotor rotates,+-- this value decrements. When it rolls back to 25 (modular arithmetic),+-- we rotate the next Rotor.+--+-- Our Rotors are letter-agnostic. That is, they only map numeric+-- entry points to exit points. This allows us to simulate rotation+-- very simply with Lenses.+data Rotor = Rotor { _name :: Text+ , _turnover :: ℤ/26+ , _circuit :: Map (ℤ/26) (ℤ/26) } deriving (Eq,Show)+makeLenses ''Rotor++-- | Rotor I: Turnover from Q to R.+rI :: Rotor+rI = Rotor "I" (int 'Q') $ M.fromList (pairs & traverse . both %~ int)+ where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "EKMFLGDQVZNTOWYHXUSPAIBRCJ"++-- | Rotor II: Turnover from E to F.+rII :: Rotor+rII = Rotor "II" (int 'E') $ M.fromList (pairs & traverse . both %~ int)+ where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "AJDKSIRUXBLHWTMCQGZNPYFVOE"++-- | Rotor III: Turnover from V to W.+rIII :: Rotor+rIII = Rotor "III" (int 'V') $ M.fromList (pairs & traverse . both %~ int)+ where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "BDFHJLCPRTXVZNYEIWGAKMUSQO"++-- | Rotor IV: Turnover from J to K.+rIV :: Rotor+rIV = Rotor "IV" (int 'J') $ M.fromList (pairs & traverse . both %~ int)+ where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "ESOVPZJAYQUIRHXLNFTGKDCMWB"++-- | Rotor V: Turnover from Z to A.+rV :: Rotor+rV = Rotor "V" (int 'Z') $ M.fromList (pairs & traverse . both %~ int)+ where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "VZBRGITYUPSDNHLXAWMJQOFECK"++-- | A unmoving map, similar to the Rotors, which feeds the electrical+-- current back into Rotors. This would never feed the left Rotor's letter+-- back to itself, meaning a plaintext character would never encrypt+-- to itself. This was a major weakness in scheme which allowed the Allies+-- to make Known Plaintext Attacks against the machine.+type Reflector = Map (ℤ/26) (ℤ/26)++ukwB :: Reflector+ukwB = M.fromList (pairs & traverse . both %~ int)+ where pairs = zip "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "YRUHQSLDPXNGOKMIEBFZCWVJAT"++-- | A set of 10 pairs of connected letters which would map letters+-- to other ones both before and after being put through the Rotors.+-- The remaining six unpaired letters can be thought of mapping to themselves.+type Plugboard = Map (ℤ/26) (ℤ/26)++-- | Essentially the machine itself. It is made up of:+-- 1. Three rotor choices from five, in a random placement.+-- 2. Initial settings of those Rotors.+-- 3. The Reflector model in use.+-- 4. Plugboard settings (pairs of characters).+data EnigmaKey = EnigmaKey { _rotors :: [Rotor]+ , _settings :: [Char]+ , _reflector :: Reflector+ , _plugboard :: Plugboard+ } deriving (Eq,Show)+makeLenses ''EnigmaKey++-- | Note that the randomly generated initial Rotor positions are not+-- applied to the Rotors when the key is generated. They have to+-- be applied before first use.+instance Key EnigmaKey where+ key g = EnigmaKey rs ss ukwB $ randPlug g+ where rn = 3 -- Number of Rotors to use.+ rs = take rn $ shuffle g [rI,rII,rIII,rIV,rV] 5+ ss = randChars g rn++-- | Generate random start positions for the Rotors.+randChars :: CPRG g => g -> Int -> [Char]+randChars _ 0 = []+randChars g n = c : randChars g' (n-1)+ where (c,g') = generateBetween g 0 25 & _1 %~ letter . toMod++-- | Generate settings for the Plugboard. Ten pairs of characters will+-- be mapped to each other, and the remaining six characters will map+-- to themselves.+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 = foldr (\v acc -> (v,v) : acc) [] ss
+ Crypto/Classical/Util.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++-- |+-- Module : Crypto.Classical.Util+-- Copyright : (c) Colin Woodbury, 2015+-- License : BSD3+-- Maintainer: Colin Woodbury <colingw@gmail.com>++module Crypto.Classical.Util+ (+ -- * Character Conversion+ letter+ , int+ -- * Modular Arithmetic+ , inverse+ -- * Random Numbers+ , prng+ , rseq+ -- * Map function+ , mapInverse+ , compose+ , (|.|)+ -- * Miscellaneous+ , uniZip+ ) where++import Control.Lens+import Crypto.Number.Generate+import Crypto.Number.ModArithmetic (inverseCoprimes)+import Crypto.Random+import Data.Char+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as M+import Data.Modular++---++letter :: ℤ/26 -> Char+letter l = chr $ ord 'A' + (fromIntegral $ unMod l)++int :: Char -> ℤ/26+int c = toMod . toInteger $ ord c - ord 'A'++-- | Must be passed a number coprime with 26.+inverse :: ℤ/26 -> ℤ/26+inverse a = toMod $ inverseCoprimes (unMod a) 26++prng :: IO SystemRNG+prng = fmap cprgCreate createEntropyPool++-- | The sequence (r1,...r[n-1]) of numbers such that r[i] is an+-- independent sample from a uniform random distribution+-- [0..n-i]+rseq :: CPRG g => g -> Integer -> [Integer]+rseq g n = rseq' g (n - 1) ^.. traverse . _1+ where rseq' :: CPRG g => g -> Integer -> [(Integer, g)]+ rseq' _ 0 = []+ rseq' g' i = (j, g') : rseq' g'' (i - 1)+ where (j, g'') = generateBetween g' 0 i++-- | Invert a Map. Keys become values, values become keys.+-- Note that this operation may result in a smaller Map than the original.+mapInverse :: (Ord k, Ord v) => Map k v -> Map v k+mapInverse = M.foldrWithKey (\k v acc -> M.insert v k acc) M.empty++-- | Compose two Maps. If some key `v` isn't present in the second+-- Map, then `k` will be left out of the result.+--+-- 2015 April 16 @ 13:56+-- Would it be possible to make a Category for Map like this?+compose :: (Ord k, Ord v) => Map k v -> Map v v' -> Map k v'+compose s t = M.foldrWithKey f M.empty s+ where f k v acc = case M.lookup v t of+ Nothing -> acc+ Just v' -> M.insert k v' acc++-- | An alias for compose. Works left-to-right.+(|.|) :: (Ord k, Ord v) => Map k v -> Map v v' -> Map k v'+(|.|) = compose++-- | Zip a list on itself. Takes pairs of values and forms a tuple.+-- Example:+--+-- >>> uniZip [1,2,3,4,5,6]+-- [(1,2),(3,4),(5,6)]+uniZip :: [a] -> [(a,a)]+uniZip [] = []+uniZip [_] = []+uniZip (a:b:xs) = (a,b) : uniZip xs
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Colin Woodbury++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Colin Woodbury nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ crypto-classical.cabal view
@@ -0,0 +1,71 @@+-- The name of the package.+name: crypto-classical++version: 0.0.1++synopsis: An educational tool for studying classical cryptography schemes.++description: An educational tool for studying classical cryptography+ schemes. Do not encrypt anything of worth with this+ library.++homepage: https://github.com/fosskers/crypto-classical++license: BSD3++license-file: LICENSE++author: Colin Woodbury++maintainer: colingw@gmail.com++category: Cryptography++build-type: Simple++cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/fosskers/crypto-classical.git+ +library+ exposed-modules: Crypto.Classical+ , Crypto.Classical.Cipher+ , Crypto.Classical.Letter+ , Crypto.Classical.Shuffle+ , Crypto.Classical.Types+ , Crypto.Classical.Test+ , Crypto.Classical.Util+ , Crypto.Classical.Cipher.Caesar+ , Crypto.Classical.Cipher.Affine+ , Crypto.Classical.Cipher.Stream+ , Crypto.Classical.Cipher.Substitution+ , Crypto.Classical.Cipher.Vigenere+ , Crypto.Classical.Cipher.Enigma+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- LANGUAGE extensions used by modules in this package.+ -- other-extensions: + + -- Other library packages from which modules are imported.+ build-depends: QuickCheck >= 2.8.1+ , base >=4.7 && <4.9+ , bytestring+ , containers >= 0.5.5.1+ , crypto-numbers >= 0.2.7+ , crypto-random+ , lens >= 4.7+ , modular-arithmetic >= 1.2.0.0+ , random+ , random-shuffle >= 0.0.4+ , text >= 1.2.0.4+ , transformers >= 0.4.2.0+ + -- Directories containing source files.+ -- hs-source-dirs: + + -- Base language which the package is written in.+ default-language: Haskell2010