4
\$\begingroup\$

I wrote a program in haskell that aims to let the user encrypt, decrypt and crack/cryptanalyse pre-electromechanical era ciphers in Haskell. I want to know your opinion on it since this is my first Haskell project and so my approach to it is slightly different from the approach I would make on other languages.

It currently supports Caesar, Vigenere and ADFGVX ciphers and lets the user crack the first two. It also lets the user perform some cryptanalysis methods like count letter/substring frequencies and substituting letters until the user is satisfied with the result.

My code has a lot of functions defined on the top-level so I'm starting to get a bit worried if I should have defined some of them locally. I'm also a bit worried about the types of my functions because maybe some of them could be more generalized.

Please bear in mind, that the Vigenere cracking and the ADFGVX implementations have still some work to do. As for the Vigenere cracking, the user has to manually enter the mininum and maximum size of the words that are repeated along the ciphertext to be searched for (Kasiski algorithm) and the ADFGVX encryption and decryption still doesn't work 100% because i'm filling the ciphertext with the letter 'a' until it fits totally on the grid.

I will show you all the modules starting from the CLI (since it acts as the main method).

cct.hs

import Control.Monad
import System.Exit
import System.IO
import MyUtils
import Ciphers.Caesar
import Ciphers.Vigenere
import Ciphers.ADFGVX
import Codebreaking.Cryptanalysis
import Codebreaking.VigenereCrack

caesarEncryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the shift number:"
  shift <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let shift_int = (read shift :: Int) --convert input to int
  let ciphertext = caesarShift shift_int message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Ciphertext:"
  print (ciphertext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

vigenereEncryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the desired keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let ciphertext = vigenereEncrypt key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Ciphertext:")
  print (ciphertext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

adfgvxEncryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "The program will now read the substitution key from my_grid.txt."
  putStrLn "Do you want to change it (y/n)?"
  input1 <- getLine
  when (input1 == "y") (do createSubstitutionKey; putStrLn "Substitution key created.")
  handle <- openFile "my_grid.txt" ReadMode
  substitution_key <- hGetContents handle
  putStrLn "Enter the desired keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let ciphertext = adfgvxEncrypt substitution_key key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Ciphertext:")
  print (ciphertext)
  putStrLn "\nDon't forget to share the substitution key with the recipient"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input2 <- getLine
  main

caesar_decryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the shift number:"
  shift <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let shift_int = (read shift :: Int) --convert input to int
  let plaintext = caesarShift (-shift_int) message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Plaintext:"
  print (plaintext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

vigenereDecryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let plaintext = vigenereDecrypt key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Plaintext:")
  print (plaintext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

adfgvxDecryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "The program will now read the substitution key from my_grid.txt."
  handle <- openFile "my_grid.txt" ReadMode
  substitution_key <- hGetContents handle
  putStrLn "Enter the keyword:"
  key <- getLine
  putStrLn "Enter the message:"
  message <- getLine
  let plaintext = adfgvxDecrypt substitution_key key message
  clearAll
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn ("Plaintext:")
  print (plaintext)
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Press any key to return to the main menu."
  input <- getLine
  main

decryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::1 - Caesar's cipher                                                          ::"
  putStrLn "::2 - Vigenere's cipher                                                        ::"
  putStrLn "::3 - ADFGVX                                                                   ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::r - Return   e - Exit                                                        ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "1" -> caesar_decryption
    "2" -> vigenereDecryption
    "3" -> adfgvxDecryption
    "r" -> main
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      encryption

encryption = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::1 - Caesar's cipher                                                          ::"
  putStrLn "::2 - Vigenere's cipher                                                        ::"
  putStrLn "::3 - ADFGVX                                                                   ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::r - Return   e - Exit                                                        ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "1" -> caesarEncryption
    "2" -> vigenereEncryption
    "3" -> adfgvxEncryption
    "r" -> main
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      encryption

tools :: String -> String -> IO()
tools ciphertext guess = forever $ do
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Ciphertext:"
  print (ciphertext)
  putStrLn ""
  putStrLn "My guess:"
  print (guess)
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::0 - Display the letter frequency in descending order                         ::"
  putStrLn "::1 - Break Caesar's cipher                                                    ::"
  putStrLn "::2 - Break Vigenere's cipher (Babbage/Kasiski Algorithm)                      ::"
  putStrLn "::3 - Get repeated substrings                                                  ::"
  putStrLn "::4 - Count the occurrences of a substring                                     ::"
  putStrLn "::5 - Count the occurrences of a letter immediately before/after other letters ::"
  putStrLn "::6 - Count the occurrences of a letter immediately before other letters       ::"
  putStrLn "::7 - Count the occurrences of a letter immediately after other letters        ::"
  putStrLn "::8 - Substitute a letter by another in the ciphertext                         ::"
  putStrLn "::r - Return                                                                   ::"
  putStrLn "::e - Exit                                                                     ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "0" -> do
      putStrLn ""
      putStrLn "Letter frequency:"
      print (sortAlphabetCount ciphertext)
      putStrLn ""
    "1" -> do
      putStrLn ""
      print(breakCaesar ciphertext)
      putStrLn ""
    "2" -> do
      putStrLn ""
      putStrLn "For this tool to work it is necessary to find some substrings that have multiple occurrences along the ciphertext."
      crackVigenere ciphertext
    "3" -> do
      putStrLn ""
      putStrLn "Enter the minimum size of the substrings to be searched for:"
      min_size <- getLine
      putStrLn "Enter the maximum size of the substrings to be searched for:"
      max_size <- getLine
      let min_size_int = (read min_size :: Int)
          max_size_int = (read max_size :: Int)
      putStrLn "Repeated substrings:"
      print (repeatedSubs min_size_int max_size_int ciphertext)
    "4" -> do
      putStrLn ""
      putStrLn "Enter the substring:"
      substring <- getLine
      putStrLn "Occurrences:"
      print(countSubstring substring ciphertext)
      putStrLn ""
    "5" -> do
      putStrLn ""
      putStrLn "Enter the letter(between ''):"
      letter <- getLine
      let letter_char = (read letter :: Char)
      putStrLn "Occurrences:"
      print(countAllNeighbours letter_char ciphertext)
      putStrLn ""
    "6" -> do
      putStrLn ""
      putStrLn "Enter the letter(between ''):"
      letter <- getLine
      let letter_char = (read letter :: Char)
      putStrLn "Occurrences:"
      print(countAllBefore letter_char ciphertext)
      putStrLn ""
    "7" -> do
      putStrLn ""
      putStrLn "Enter the letter(between ''):"
      letter <- getLine
      let letter_char = (read letter :: Char)
      putStrLn "Occurrences:"
      print(countAllAfter letter_char ciphertext)
      putStrLn ""
    "8" -> do
      putStrLn ""
      putStrLn "Enter the letter(between '') you wish to substitute:"
      letter1 <- getLine
      let letter1_char = (read letter1 :: Char)
      putStrLn "Enter the letter(beween '') to substitute by:"
      letter2 <- getLine
      let letter2_char = (read letter2 :: Char)
          new_ciphertext = substitute letter1_char letter2_char guess
      putStrLn "New ciphertext:"
      print(new_ciphertext)
      tools ciphertext new_ciphertext
    "r" -> main
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      tools ciphertext guess

crack = do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "Enter the message:"
  ciphertext <- getLine
  tools ciphertext ciphertext

main = forever $ do
  clearAll
  putStrLn ""
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::  /$$$$$$           /$$$$$$       /$$$$$$$$                                  ::"
  putStrLn ":: /$$__  $$         /$$__  $$     |__  $$__/                                  ::"
  putStrLn "::| $$  __/ /$$ /$$ | $$  __/  /$$ /$$| $$                                     ::"
  putStrLn "::| $$      |__/|__/| $$      |__/|__/| $$                                     ::"
  putStrLn "::| $$              | $$              | $$                                     ::"
  putStrLn "::| $$    $$ /$$ /$$| $$    $$ /$$ /$$| $$                                     ::"
  putStrLn "::|  $$$$$$/|__/|__/|  $$$$$$/|__/|__/| $$                                     ::"
  putStrLn ":: |______/           |______/         |__/                                    ::"
  putStrLn "::::::::Classic Cryptography Toolbox:::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::                                                                             ::"
  putStrLn "::What would you like to do?                                                   ::"
  putStrLn "::                                                                             ::"
  putStrLn "::1 - Encrypt a message                                                        ::"
  putStrLn "::2 - Decrypt a message                                                        ::"
  putStrLn "::3 - Cryptanalyse an encrypted message                                        ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  putStrLn "::e - Exit                                                                     ::"
  putStrLn ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::"
  input <- getLine
  case input of
    "1" -> encryption
    "2" -> decryption
    "3" -> crack
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn ("Please enter a valid option")
      main

MyUtils.hs

module MyUtils where

import Data.Char
import Data.List
import System.Console.ANSI
import System.Random

--lowercase letter to int conversion
let2int :: Char -> Int
let2int c = ord c - ord 'a'

--int to lowercase letter conversion
int2let :: Int -> Char
int2let n = chr(ord 'a' + n)

--converts an entire string an array of ints (each char -> int)
text2ints :: String -> [Int]
text2ints xs = map (let2int) xs

--convrets an array of ints into a string (each int -> char)
ints2text :: [Int] -> String
ints2text xs = map (int2let) xs

--shifts the given lowercase letter n positions
shift :: Int -> Char -> Char
shift n c |isLower c = int2let((let2int c + n) `mod` 26)
          |otherwise = c

--gets the factors of n
factors :: Int -> [Int]
factors n = [x |x<-[2..n], n`mod`x == 0]

--deletes all occurrences of an element within a list
deleteAll :: Eq a => a -> [a] -> [a]
deleteAll x s = filter (/=x) s

--gives a list of all the elements that have multiple occurrences within a list
equals :: Eq a => [a] -> [a]
equals [] = []
equals (x:xs)
  |elem x xs = x : equals (deleteAll x xs)
  |otherwise = equals xs

--gives a list of all the elements that are common to all the lists within a list of lists
commonElems :: Eq a => [[a]] -> [a]
commonElems l = equals [x | y<-l, x<-y, length (filter (elem x) l) == length l]

--gives a list of all the factors in common to all the integers in a list
commonFactors :: [Int] -> [Int]
commonFactors xs
  |length xs == 1 = factors (head (xs))
  |otherwise = commonElems [factors x | x<-xs]

--gives a list of the indexes of each occurrence of a substring within a string
matchIndices :: (Eq a, Num b, Enum b) => [a] -> [a] -> [b]
matchIndices needle = map fst . filter (isPrefixOf needle . snd) . zip [0..] . tails

--gives a list of the lengths between each consecutive occurrences of a substring within a string
spaceBetween :: String -> String -> [Int]
spaceBetween needle = diffs . matchIndices needle -- calculates the difference between each consecutive index
  where diffs xs = zipWith (flip(-)) xs (tail xs)

--count the space between the first occurrence of a subtring and the next occurrence within a string
repeatSpacing :: String -> String -> Int
repeatSpacing substring ciphertext
  |spaceBetween substring ciphertext == [] = 0
  |otherwise = head (spaceBetween (substring) (ciphertext))

--gives a list of the lengths between the first occurrence of multiple substrings and the next respective occurrence
multRepeatSpacing :: [String] -> String -> [Int]
multRepeatSpacing substrings ciphertext = [y | x<-substrings, y<-[repeatSpacing x ciphertext]]

--gets all chars n chars away from each other
getSpacedLetters :: Int -> String -> String
getSpacedLetters n (x:xs)
  |n > length xs = [x]
  |otherwise = x : getSpacedLetters n (drop (n-1) xs)

--gets all chars "size" chars away from each other starting from the nth position
getNthSpacedLetters :: Int -> Int -> String -> String
getNthSpacedLetters size n s
  |n > length s = ""
  |otherwise = getSpacedLetters size (drop (n-1) s)

--removes all tuples with x as fst
removeAllTuplesByInt :: Int -> [(a,Int)] -> [(a,Int)]
removeAllTuplesByInt x [] = []
removeAllTuplesByInt x list
  |snd (head list) /= x = head list : removeAllTuplesByInt x (tail list)
  |otherwise = removeAllTuplesByInt x (tail list)

--gets the index of a char in a dictionary of type [(Char,Integer)]
getDictIndex :: Eq a => a -> [(a,Integer)] -> Integer
getDictIndex c [key]
  |c == fst key = snd key
  |otherwise = error "no such element"
getDictIndex c dict
  |c == fst (head dict) = snd (head dict)
  |otherwise = getDictIndex c (tail dict)

--gives a list of the elements in a list withou repeating them
delRepeated :: Eq a => [a] -> [a]
delRepeated [] = []
delRepeated list = x : delRepeated (deleteAll x (tail list))
  where x = head list

--clears the terminal and sets the cursor position to 0 0
clearAll :: IO()
clearAll = do
  clearScreen
  setCursorPosition 0 0

--converts something of type a into the corresponding value of type b in a dictionary of the type [(b,a)]
convertTo :: Eq a => a -> [(b,a)]-> b
convertTo x [] = error ("int not found in the dict")
convertTo x dict
  |x == (snd (head dict)) = fst (head dict)
  |otherwise = convertTo x (tail dict)

convertFrom :: Eq a => a -> [(a,b)] -> b
convertFrom x [] = error ("not found in the dict")
convertFrom x dict
  |x == (fst (head dict)) = snd (head dict)
  |otherwise = convertFrom x (tail dict)

--converts an entire list into the corresponding dictionary values
toDictValue :: Eq a => [a] -> [(b,a)] -> [b]
toDictValue ns dict = map (\x -> convertTo x dict) ns

--generates a list of different random integers from n1 to n2 of size n2
genRandNrs :: Integer -> Integer -> IO([Integer])
genRandNrs n1 n2 = do
  g <- newStdGen
  return (take (fromIntegral n2) (nub (randomRs (n1,n2) g :: [Integer])))

--groups the given list in a list of lists in, n by n
groupN:: Int -> [a] -> [[a]]
groupN 0 _ = []
groupN size [] = []
groupN size s = (take (size) s) : groupN size (drop size s)

Cryptanalysis.hs

module Codebreaking.Cryptanalysis where

import Data.Char
import Data.List
import Data.Function
import MyUtils

alphabet = "abcdefghijklmnopqrstuvwxyz"

--most to least frequent letters in english with respective index
etaoin = zip "etaoinshrdlcumwfgypbvkjxqz" [1..]

en_letter_most_freq = "etaoin" --most frequent english letters
en_letter_least_freq = "vkjxqz" --least frequent english letters

--counts the number of ocurrences of a char in a string
count :: Char -> String -> Int
count a [x]
  |a == x = 1
  |otherwise = 0
count a (x:xs)
  |a == x = 1 + count a xs
  |otherwise = count a xs

--counts the numbers of ocurrences of a string in another string
countSubstring :: String -> String -> Int
countSubstring s1 s2
  |length s1 > length s2 = 0
  |take (length s1) s2 == s1 = 1 + countSubstring s1 (drop 1 s2)
  |otherwise = countSubstring s1 (drop 1 s2)

--given a number m and a string, finds all the substrings with size n that have multiple occurrences on the given string
repeatedSubsBySize :: Int -> String -> [String]
repeatedSubsBySize n [] = []
repeatedSubsBySize n s
  |countSubstring (take n s) s > 1 = (take n s) : repeatedSubsBySize n (drop 1 s)
  |otherwise = repeatedSubsBySize n (drop 1 s)

--finds all the substrings with sizes between n1 and n2 that have multiple occurrences on the given string
repeatedSubs :: Int -> Int -> String -> [String]
repeatedSubs n1 n2 [] = []
repeatedSubs n1 n2 s = [sub | n<-[n1..n2], sub<-repeatedSubsBySize n s]

--counts the number of ocurrences of each letter of the alphabet in a string
countAlphabet :: String -> [(Char, Int)]
countAlphabet s = [(letter,occurs) | letter<-alphabet, occurs<-[count letter s]]

--outputs the result of count alphabet from the most frequent letter to the least
sortAlphabetCount :: String -> [(Char, Int)]
sortAlphabetCount s = reverse (sortOn (snd) (countAlphabet s))

--substitutes all occurrences of c1 by c2 on the given string
substitute :: Char -> Char -> String -> String
substitute c1 c2 [] = []
substitute c1 c2 (x:xs)
  |c1 == x = toUpper c2 : substitute c1 c2 xs
  |otherwise = x : substitute c1 c2 xs

--counts the occurrences of c1 immediately before c2
countBefore :: Char -> Char -> String -> Int
countBefore c1 c2 [x] = 0
countBefore c1 c2 (x:xs)
  |head xs == c2 && x == c1 = 1 + countBefore c1 c2 xs
  |otherwise = 0 + countBefore c1 c2 xs

--counts the occurrences of c1 immediately after c2
countAfter :: Char -> Char -> String -> Int
countAfter c1 c2 [x] = 0
countAfter c1 c2 (x:xs)
  |x == c2 && head xs == c1 = 1 + countAfter c1 c2 xs
  |otherwise = 0 + countAfter c1 c2 xs

-- counts the ocurrences of c1 immediately before or after c2
countNeighbours :: Char -> Char -> String -> Int
countNeighbours c1 c2 s = (countBefore c1 c2 s) + (countAfter c1 c2 s)

--counts the occurrences of c immediately before or after every letter of the alphabet
countAllNeighbours :: Char -> String -> [(Char, Int)]
countAllNeighbours c s = [(letter, occurs) | letter<-alphabet, occurs<-[countNeighbours c letter s]]

--counts the occurrences of c immediately before every letter of the alphabet
countAllBefore :: Char -> String -> [(Char, Int)]
countAllBefore c s = [(letter, occurs) | letter<-alphabet, occurs<-[countBefore c letter s]]

--counts the occurrences of c immediately after every letter of the alphabet
countAllAfter :: Char -> String -> [(Char, Int)]
countAllAfter c s = [(letter, occurs) | letter<-alphabet, occurs<-[countAfter c letter s]]

--attributes a letter frequency score to the first 6 letters in a string
matchFreqScoreFirst :: String -> Int
matchFreqScoreFirst [] = 0
matchFreqScoreFirst s
  |elem (head sorted_first) en_letter_most_freq = 1 + matchFreqScoreFirst (drop 1 sorted_first)
  |otherwise = 0 + matchFreqScoreFirst (drop 1 sorted_first)
    where sorted_first = take 6 s

--attributes a letter frequency score to the last 6 letters in a string
matchFreqScoreLast :: String -> Int
matchFreqScoreLast [] = 0
matchFreqScoreLast s
  |elem (head sorted_last) en_letter_least_freq = 1 + matchFreqScoreLast (drop 1 sorted_last)
  |otherwise = 0 + matchFreqScoreLast (drop 1 sorted_last)
    where sorted_last = take 6 (reverse s)

--sorts the strings in the tuple in reverse ETAOIN order
reverseEtaoinSortFreqs :: [(Int, String)] -> [(Int, String)]
reverseEtaoinSortFreqs [] = []
reverseEtaoinSortFreqs [x]
  |length (snd x) > 1 = [(fst x, reverseEtaoinSort (snd x))]
  |otherwise = [x]
reverseEtaoinSortFreqs (x:xs)
  |length (snd x) > 1 = (fst x, reverseEtaoinSort (snd x)) : reverseEtaoinSortFreqs xs
  |otherwise = x : reverseEtaoinSortFreqs xs

--gives a list of frequencies and the respective group of letters
sortFreqToLetters :: String -> [(Int, String)]
sortFreqToLetters s = reverseEtaoinSortFreqs [(snd (head gr), map fst gr) | gr <- groupBy ((==) `on` snd) (sorted_freqs)]
    where
      sorted_freqs = (sortAlphabetCount s)

--inserts a letter in a "reverse_etaoin" ordered string keeping its order
reverseEtaoinInsert :: Char -> String -> String
reverseEtaoinInsert c [] = [c]
reverseEtaoinInsert c (x:xs)
  |(getDictIndex c etaoin) > (getDictIndex x etaoin) = c : x : xs
  |otherwise = x : reverseEtaoinInsert c xs

--sorts a string in reverse ETAOIN order
reverseEtaoinSort :: String -> String
reverseEtaoinSort [] = []
reverseEtaoinSort (x:xs) = reverseEtaoinInsert x (reverseEtaoinSort xs)

--gives the 2 highest ints in lust of (Char,Int)
getHighestFreqScores :: [(Char,Int)] -> [Int]
getHighestFreqScores scores = [maximum (map (snd) scores),maximum (map (snd) rest)]
  where rest = removeAllTuplesByInt (maximum (map (snd) scores)) scores

--outputs the letters corresponding to the given highest freq scores
getHighestLetters :: [Int] -> [(Char,Int)] -> String
getHighestLetters highest_scores [] = []
getHighestLetters highest_scores scores
  |elem (snd (head scores)) highest_scores = fst (head scores) : getHighestLetters highest_scores (tail scores)
  |otherwise = getHighestLetters highest_scores (tail scores)

--given a reverse_etaoin sorted string, attributes a frequency match score
matchFreqScore :: String -> Int
matchFreqScore s = matchFreqScoreFirst s + matchFreqScoreLast s

--gets the reverse etaoin sorted string of a string
sortedEtaoinString :: String -> String
sortedEtaoinString x = concat (map (snd) (init (sortFreqToLetters x)))

Caesar.hs

module Ciphers.Caesar where

import MyUtils
import Data.Char

--encrypts(n) or decrypts(-n)
caesarShift :: Int -> String -> String
caesarShift n xs = [shift n x | x <- map (toLower) xs]

--given a string, shifts it 26 times and generates a list with all of the shifted strings
--one of the elements might mean something
breakCaesar :: String -> [String]
breakCaesar xs = [s | n<-[(0)..(25)], s<- [caesarShift (-n) (map (toLower) xs)]]

Vigenere.hs

module Ciphers.Vigenere where

import MyUtils
import Data.Char

--encrypts the plaintext with the given key
vigenereEncrypt :: String -> String -> String
vigenereEncrypt key plaintext = ints2text result
  where result = map (`mod` 26) (zipWith (+)  keyCycle intPlainText)
        keyCycle = (cycle(text2ints key))
        intPlainText = text2ints (map (toLower) (filter (isAlphaNum) plaintext))

--decrypts the ciphertext with the given key
vigenereDecrypt :: String -> String -> String
vigenereDecrypt key ciphertext = ints2text result
  where result = map (`mod` 26) (zipWith (-)  intciphertext keyCycle)
        keyCycle = (cycle(text2ints key))
        intciphertext = text2ints (map (toLower)(filter (isAlphaNum) ciphertext))

ADFGVX.hs

module Ciphers.ADFGVX where

import Control.Monad
import System.Directory
import Data.List
import Data.Char
import Data.Maybe
import MyUtils

grid = sequence ["adfgvx","adfgvx"]
alpha_nums = zip ['a'..'z'] [1..] ++ zip ['0'..'9'] [27..]

--creates a file with a random substitution key
createSubstitutionKey :: IO()
createSubstitutionKey = do
  let filename = "my_grid.txt"
  fileExists <- doesFileExist (filename)
  when fileExists (removeFile filename)
  rands <- genRandNrs 1 36--random list of alpha_nums indexes
  writeFile filename (toDictValue rands alpha_nums)

--fills the ADFGVX grid with the given string
fillGrid :: String -> [(String,Char)]
fillGrid s = zip grid s

--substitutes all chars in a string for their respecive value in the ADFGVX grid
substitutionStep :: String -> [(String,Char)] -> String
substitutionStep plaintext filled_grid = concat (toDictValue plaintext filled_grid)

--attributes each letter in the ciphertext to each letter of the key in a cyclic fashion
--if the the ciphertext leaves blank spaces on the gird, fills it with encrypted 'a's
createKeyGrid :: String -> String -> [(Char,Char)]
createKeyGrid key ciphertext = zip (cycle key) fit_ciphertext
  where fit_ciphertext = if length (ciphertext) `mod` length (key) == 0 then ciphertext else ciphertext ++ replicate (rest) 'a'
        rest = length key - length (ciphertext) `mod` length (key)

--sorts the key grid columns in alphabetical order
sortKeyGrid :: String -> [(Char,Char)] -> [(Char,Char)]
sortKeyGrid key [] = []
sortKeyGrid key keygrid = sortOn (fst) (take (length key) keygrid) ++ (sortKeyGrid key (drop (length key) keygrid))

--ouputs the key grid with the columns as lines
groupByCols :: Eq a => [(a,b)] -> [(a,b)]
groupByCols [] = []
groupByCols [x] = [x]
groupByCols (x:xs) = [x] ++ (filter (\t -> fst(t) == fst(x)) xs) ++ groupByCols (filter (\t2 -> fst(t2) /= fst(x)) xs)

--gives the elements of the key grid as a string
transpositionStep :: String -> [(Char,Char)] -> String
transpositionStep key keygrid = map (snd) (groupByCols sorted_keygrid)
  where sorted_keygrid = sortKeyGrid key keygrid

--given a key, sorts the key and fills the grid the same way it was on the encryption process
recreateKeyGrid :: String -> String -> [(Char,String)]
recreateKeyGrid key ciphertext = zip (sorted_key) (groupN nrows ciphertext)
  where nrows = cipher_text_size `div` key_size
        sorted_key = sort key
        cipher_text_size = length ciphertext
        key_size = length key

--sorts the columns of the grid by the order of the password
unSortKeyGrid :: String -> [(Char,String)] -> [(Char,String)]
unSortKeyGrid key [] = []
unSortKeyGrid key keygrid = found : unSortKeyGrid (drop 1 key) (delete found keygrid)
  where found = fromJust (find (\x -> fst(x) == head key) keygrid)

--get the untransposed text from the unsorted grid
getPreCipherText :: [(Char,String)] -> [String]
getPreCipherText keygrid = groupN 2 [s | n<-[1..nrows], s<-getNthSpacedLetters (nrows) n gridstring]--(map (head) (map (snd) keygrid)) ++ getPreCipherText (map (tail) (map (snd) keygrid))
  where gridstring = concat (map (snd) keygrid)
        nrows = length (snd (head keygrid))

--converts the untransposed text into plaintext
getPlainText :: [String] -> [(String,Char)] -> String
getPlainText preciphertext adfgvxgrid = map (\x -> convertFrom x adfgvxgrid) preciphertext

--encryption algorithm
adfgvxEncrypt :: String -> String -> String -> String
adfgvxEncrypt substitution_key key plaintext = transpositionStep key keygrid
  where keygrid = createKeyGrid key ciphertext1
        ciphertext1 = substitutionStep (filter (isAlphaNum) (map (toLower) plaintext)) my_grid
        my_grid = fillGrid substitution_key

--decryption algorithm
adfgvxDecrypt :: String -> String -> String -> String
adfgvxDecrypt substitution_key key ciphertext = getPlainText preciphertext my_grid
  where my_grid = fillGrid substitution_key
        preciphertext = getPreCipherText (unSortKeyGrid key keygrid)
        keygrid = recreateKeyGrid key ciphertext

VigenereCrack.hs

module Codebreaking.VigenereCrack where

import Ciphers.Caesar
import Ciphers.Vigenere
import Codebreaking.Cryptanalysis
import MyUtils
import Control.Monad
import System.Exit
import System.Console.ANSI
import Control.Concurrent
import Data.Function

--given two numbers representing the min and max size of the substrings that may repeat along the ciphertext and the ciphertext gives a list of all the possible lengths of the vigenere key
guessKeyLength :: Int -> Int -> String -> [Int]
guessKeyLength n1 n2 ciphertext = commonFactors (multRepeatSpacing (repeatedSubs n1 n2 ciphertext) ciphertext)

--given a list of possible keysizes and the ciphertext, splits the ciphertext into subkey parts for each possible keysize
groupBySubkeys :: [Int] -> String -> [(Int,String)]
groupBySubkeys sizes ciphertext = [(keysize,x) | keysize<-sizes, n<-[1..keysize], x<-[getNthSpacedLetters keysize n ciphertext]]

--attributes a frequency score to each caesar shift of the string
subkeyScores :: String -> [(Char,Int)]
subkeyScores s = zip alphabet [matchFreqScore shifted | shifted <- map (sortedEtaoinString) (breakCaesar s)]

--filters the most likely subkeys out of the string
filterSubkey :: (Int,String) -> (Int,String)
filterSubkey subkey_group = (keysize, candidates)
  where keysize = fst subkey_group
        string = snd subkey_group
        candidates = getHighestLetters (getHighestFreqScores (subkeyScores (string))) (subkeyScores (string))

--outputs the possible subkeys for each position of each possible key size
possibleSubkeys :: [(Int,String)] -> [(Int,String)]
possibleSubkeys subkey_groups = map (filterSubkey) subkey_groups

--given a keysize, ouputs the components of the key
getKeysizeGroup :: Int -> [(Int,String)] -> [(Int,String)]
getKeysizeGroup x group = filter (\i -> fst i == x) group

--given a list of possible subkeys and the respective keysize, gives a list of all the keys for all the possible keysizes
possibleKeys :: [(Int,String)] -> [String]
possibleKeys subkeys = [ key | keysize <- keysizes, key<-keys keysize]
  where keysizes = delRepeated (map (fst) subkeys)
        keys x = sequence (map (snd) (getKeysizeGroup x subkeys))

--tries all the keys
bruteForceKeys :: [String] -> String -> IO()
bruteForceKeys [] ciphertext = putStrLn "\nDone"
bruteForceKeys keys ciphertext = do
  let key = head keys
  putStrLn ""
  putStrLn ("Attempting with key: " ++ key ++ " :")
  threadDelay 500000
  print(vigenereDecrypt key ciphertext)
  bruteForceKeys (drop 1 keys) ciphertext

--kasiski Algorithm
--user interaction
crackVigenere :: String -> IO()
crackVigenere ciphertext = do
  putStrLn "Enter min size of repeated words:"
  readMin <- getLine
  putStrLn "Enter max size of repeated words:"
  readMax <- getLine
  let minsize = (read readMin :: Int)
      maxsize = (read readMax :: Int)
  let key_lengths = guessKeyLength minsize maxsize ciphertext
  --putStrLn "Possible key lengths:"
  clearAll
  putStrLn "Possible keys:"
  putStrLn "Calculating possible key lengths..."
  --print (key_lengths)
  let subkey_groups = groupBySubkeys key_lengths ciphertext
  --putStrLn "Subkey groups for each possible key size:"
  --print (subkey_groups)
  let subkeys = possibleSubkeys subkey_groups
  --putStrLn "Possible subkeys:"
  --print (subkeys)
  let keys = possibleKeys subkeys
  print (keys)
  forever $ do
  putStrLn "1 - Try a key"
  putStrLn "2 - Brute-force attack"
  putStrLn "r - Retry"
  putStrLn "e - Exit"
  input <- getLine
  case input of
    "1" -> do
      key <- getLine
      let plaintext = vigenereDecrypt key ciphertext
      print (plaintext)
    "2" -> bruteForceKeys keys ciphertext
    "r" -> crackVigenere ciphertext
    "e" -> exitSuccess
    otherwise -> do
      putStrLn "Please enter a valid option."
      exitFailure
```
\$\endgroup\$
1
\$\begingroup\$

First some comments related to your module structure:

  • You may want to mirror the module structure of the cryptonite and crypto-api packages, which are the most popular cryptography packages on Hackage; Crypto.Cipher.Caesar, Crypto.Cipher.Vigenere, etc.

  • You may want to place the Vigenere crack implementation in Crypto.Cipher.Vigenere.Crack, call the method crack rather than crackVigenere (since the cipher is implied by the module), and only export crack:

    module Crypto.Cipher.Vigenere.Crack ( crack
                                        ) where
    
    ...
    

    as this provides a clean interface to the algorithm.

    If, for some reason, you wish to export the internal functions (such that they may be used by other modules), a common thing to do is to place the actual implementation in a module called Crypto.Cipher.Vigenere.Crack.Impl, and in the module Crypto.Cipher.Vigenere.Crack import this Impl but only export the public interface. This means that users of your library will know that Impl might change and should be referred to at their own risk, whereas Crack has a stable interface.

  • If you import these modules using qualified, you don't need to prefix each combinator as caesarEncrypt, vigenereEncrypt, etc. You can instead write e.g.

    import qualified Crypto.Cipher.Caesar as Caesar
    import qualified Crypto.Cipher.Vigenere as Vigenere
    
    ... Caesar.encrypt ...
    ... Vigenere.decrypt ...
    
  • Give your modules a common interface, so it's Caesar.encrypt, Caesar.decrypt, Vigenere.encrypt, Vigenere.decrypt, and finally break or crack in the corresponding implementations, whichever you choose.

  • In the ADFGVX module in particular, and also in general, consider placing the high-level definitions / the definitions you aim to explicitly export, such as encrypt and decrypt, first in the file and all its helper definitions below. This provides more clarity when reading the code.

  • The Codebreaking.Cryptanalysis module is only used in the Vigenere cipher, so perhaps name this accordingly as e.g. Crypto.Cipher.Vigenere.Analysis to clarify what its use is.

  • Since the cryptonite package already has a module Crypto.Cipher.Utils, adding your MyUtils under this name may conflict with use-cases where you wish to use both packages simultaneously.

Secondly some low-level comments related to your syntax and helper functions:

  • As Michael Chav suggested, you may want to use quasi quotation on your longer strings. As an additional suggestion, you may want to consider the module Data.FileEmbed to move your very long formattable strings to a separate file:

    import Data.FileEmbed (embedStringFile)
    
    someVeryLongStringWithWhitespaceFormatting :: String
    someVeryLongStringWithWhitespaceFormatting = $(embedStringFile "path/to/foo.txt")
    
  • But for your terminal user-interface, you may want to use a library for building this; there are quite a lot out there, and I can only personally recommend brick, but there are also byline, cli, haskeline, HCL and structured-cli.

    Depending on whether you choose one of these or not, cct.hs could see some refactoring on its own that warrants its own code review, I think. Mainly there's a lot of UI-related code duplication and some separation of displaying the UI and reacting to input that could be separated. E.g. FRP with Brick would enforce that.

  • Consider using HLint as it will provide you with a lot of helpful warnings about redundant parentheses and formatting; I won't comment on these, but there's for example quite a lot of parentheses that are not necessary and do not improve reading (one case is map (toLower) xs).

  • I assume the intent with MyUtils is to extract the most generic helper functions you've used. But it seems to me that a lot of these are dead (no longer used) or only used in one cipher. I understand that some of these helper functions are used by other helper functions inside MyUtils.

    And finally, perhaps, generic functions used in multiple ciphers?

    I'd recommend not extracting things to a common place until you need them in two places, and not export functions that are not expected to be used outside of a library. There's a principle to back this up somewhere, but I can only think of premature generalization right now.

    If this completely eradicates MyUtils, that's good.

    Notice that cryptonite's Crypto.Cipher.Utils only has a single definition.

  • As another point of comparison with the cryptonite package, you'll notice that it works on Data.ByteArray. Since your ciphers are not binary but letter-based, this is not really appropriate, but have you considered Data.Text for more efficient representation of strings? See the String Types tutorial by FPComplete for an intro.

  • Avoid a mixture of CamelCase and snake_case. You have both adfgvxEncryption and caesar_decryption.

  • You don't want as complex machinery as in Crypto.Cipher.Types, but you may want to create some type aliases to convey the meaning behind the many String and Int arguments.

    E.g. instead of

    caesarShift :: Int -> String -> String
    caesarShift n xs = [shift n x | x <- map (toLower) xs]
    
    ...
    
    vigenereEncrypt :: String -> String -> String
    vigenereEncrypt key plaintext = ...
    

    you can have

    type CaesarKey = Int
    
    encrypt :: CaesarKey -> String -> String
    encrypt key plaintext = map (shift key . toLower) plaintext
    
    ...
    
    type VigenereKey = String
    
    encrypt :: VigenereKey -> String -> String
    encrypt key plaintext = ...
    
  • The vigenereEncrypt function is nicely written in the sense of its use of combinators, so you're using Haskell's standard library quite well. Stylistically I might prefer to rewrite

    vigenereEncrypt :: String -> String -> String
    vigenereEncrypt key plaintext = ints2text result
      where result = map (`mod` 26) (zipWith (+)  keyCycle intPlainText)
            keyCycle = (cycle(text2ints key))
            intPlainText = text2ints (map (toLower) (filter (isAlphaNum) plaintext))
    

    into

    encrypt :: VigenereKey -> String -> String
    encrypt key plaintext = ints2text . encrypt' . text2ints $ plaintext'
      where
        encrypt' = map (`mod` 26) . zipWith (+) (cycle key')
        plaintext' = map toLower (filter isAlphaNum plaintext)
        key' = text2ints key
    

    although I'm still a little unsatisfied with the name and use of text2ints and ints2text.

Hope it helps.

\$\endgroup\$
  • \$\begingroup\$ Thanks! Most detailed comment so far. I really appreciate it. I'm currently cleaning the CLI part (from 300 lines to 120) and i will deal with the modulation next, then the types and finally some efficiency tweaks before proceding to tune the logic itself. Do you think this is a good way to go? \$\endgroup\$ – Guilherme Lima Apr 29 at 14:33
  • \$\begingroup\$ @GuilhermeLima: Sure, that sounds like a good plan. \$\endgroup\$ – Simon Shine Apr 30 at 7:41
2
\$\begingroup\$

I'd also maybe suggest making helper functions for pretty printing to the terminal.

screenLength :: Int
screenLength = 82

colons :: Int -> String
colons = flip replicate ':'

printFill :: IO ()
printFill = putStrLn $ colons screenLength

printFillT :: String -> IO ()
printFillT s = do
    putStrLn $ begin ++ fillSpace ++ end
    when (not $ null rest) $ printFillT rest
  where (fstStr, rest) = splitAt (screenLength - 6) s
        begin = ":: " ++ fstStr
        end = "::"
        fillSpace = replicate (screenlength - length begin - length end) ' '

printTitle :: String -> IO ()
printTitle s = putStrLn $ begin ++ s ++ end
  where begin = colons 8
        end = colons $ screenLength - length begin - length s

This way, your main functions will look a lot cleaner, and they're reusable everywhere, so there's less putStrLns filling the code:

logo :: [String]
logo =
  [ "  /$$$$$$           /$$$$$$       /$$$$$$$$"
  , " /$$__  $$         /$$__  $$     |__  $$__/"
  , "| $$  __/ /$$ /$$ | $$  __/  /$$ /$$| $$"
  , "| $$      |__/|__/| $$      |__/|__/| $$"
  , "| $$              | $$              | $$"
  , "| $$    $$ /$$ /$$| $$    $$ /$$ /$$| $$"
  , "|  $$$$$$/|__/|__/|  $$$$$$/|__/|__/| $$"
  , " \______/          \______/         |__/"
  ]

printMenu :: IO ()
printMenu = do
    putStrLn ""
    printFill
    mapM_ printFillT logo
    printTitle "Classic Cryptography Toolbox
    mapM_ printFillT menu
    printFill
    printFillT "e - Exit"
    printFill
  where menu =
          [ ""
          , "What would you like to do?"
          , ""
          , "1 - Encrypt a message"
          , "2 - Decrypt a message"
          , "3 - Cryptanalyse an encrypted message"
          , ""
          ]


main = forever $ do
  clearAll
  printMenu
  input <- getLine
  case input of
    "1" -> encryption
    "2" -> decryption
    "3" -> crack
    "e" -> exitSuccess
    otherwise -> do
      putStrLn ""
      putStrLn $ "Please enter a valid option"
```
\$\endgroup\$
  • \$\begingroup\$ thanks for the suggestion. yeah i thought so. i'm currently working on a very simple CLI framework to aid me on this project and also in future ones \$\endgroup\$ – Guilherme Lima Apr 27 at 23:10
1
\$\begingroup\$

Some quick initial comments - will edit as I move. For your cct.hs file you probably want to put different prompt lines into a list and map a print over that list for example:

import Control.Monad

mainMenuText = ["Line 1",
    "Line 2",
    "Line 3",
    ...]

main = mapM_ putStrLn mainMenuText

Or use QuasiQuuotes

{-# LANGUAGE QuasiQuotes #-}
import Data.String.QQ

main = putStrLn [s|
Line 1
Line 2
Line 3|]

Or use multiline strings:

main = putStrLn "Line 1 \n \
                \ Line 2 \n \
                \ Line 3"

You may also want to an enum for each case statement menu so if need be you can pass around the value and it makes sense everywhere. In your case "1" being encryption is lost fairly early. I suggest adding a data type for the command:

data Command = ENCRYPTION | DECRYPTION | ...

So that you have one function to do both encryption and decryption:

type Message = String
type Shift = Int

caesarCipher :: Command -> Message -> Shift -> String 

Or something of that nature. It'll make the interface cleaner.

Also be consistent in your use of camelCase.

This is a lot of code but lemme get to the parts which I think are worth addressing.

The commonElems function seems grossly inefficient. Checking that each item appears in every list by doing a length check then removing duplicates seems confusing. I think the simpler algorithm would be to take the unions of the running intersections.

import Data.List

commonElems xs = foldr intersect intialElement xs
  where initialElement = if (null xs) then [] else (head xs) 

matchIndices would look better with explicit recursion.

matchIndices needle haystack = go needle haystack 0
  where go _ [] _        = []
        go n (x:xs)@h i  = if n `isPrefixOf` h then i : (go n xs (i + 1)) else (go n xs (i + 1))
\$\endgroup\$
  • \$\begingroup\$ thank you very much for going through my code and for your suggestions! i will apply those \$\endgroup\$ – Guilherme Lima Apr 27 at 16:39
  • \$\begingroup\$ On having encrypt/decrypt in a single function: I agree with the sentiment of making the interface cleaner, but I object to the method. Functions should do one thing, as adviced by Robert C. Martin's Clean Code. What you can do instead is have common interfaces to different modules, e.g. Ciphers.Caesar.(encrypt, decrypt, crack), Ciphers.Vigenere.(encrypt, decrypt, crack) and let them have common type signatures, to the extent that it's possible. \$\endgroup\$ – Simon Shine Apr 29 at 9:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.