The Matasano Crypto Challenges Set 1 (http://cryptopals.com/sets/1)

Set1.hs

module Set1 where

import qualified Data.Map.Strict as M
import Data.Bits
import Data.Word
import Data.Char (toLower)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C

-- Helpers
stringToBytes :: String -> [Word8]
stringToBytes = BS.unpack . C.pack

charToBytes :: Char -> [Word8]
charToBytes = BS.unpack . C.singleton

bytesToString :: [Word8] -> String
bytesToString = C.unpack . BS.pack

-- Set 1, Challenge 1: Base64 encoding -----------------------------------------
base64Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
base64Dict = M.fromList $ zip [0..] base64Chars
getBase64Char b = M.findWithDefault ' ' b base64Dict

encodeTriple :: Word8 -> Word8 -> Word8 -> String
encodeTriple a b c =
  map getBase64Char $ zipWith (.|.)
    (map transform [(a, -2, 0x3f), (a,  4, 0x30), (b,  2, 0x3c), (c, 0, 0x3f)])
    (map transform [(0,  0,    0), (b, -4, 0x0f), (c, -6, 0x03), (0, 0,    0)])
  where
    transform (a, s, m) = a `shift` s .&. m

bytesToBase64 :: [Word8] -> String
bytesToBase64 [] = []
bytesToBase64 [a] = take 2 (encodeTriple a 0 0) ++ "=="
bytesToBase64 [a, b] = take 3 (encodeTriple a b 0) ++ "="
bytesToBase64 (a:b:c:xs) = encodeTriple a b c ++ bytesToBase64 xs

stringToBase64 :: String -> String
stringToBase64 = bytesToBase64 . stringToBytes

-- Set 1, Challenge 2: hex string conversion -----------------------------------
hexChars = "0123456789abcdef"
hexDict = M.fromList $ zip hexChars [0..]
hexToByte c = M.findWithDefault 0 (toLower c) hexDict

hexRevDict = M.fromList $ zip [0..] hexChars
byteToHex b = M.findWithDefault ' ' b hexRevDict

hexStringToBytes :: String -> [Word8]
hexStringToBytes [] = []
hexStringToBytes [a] = [0]
hexStringToBytes (a:b:xs) = 16 * hexToByte a + hexToByte b : hexStringToBytes xs

bytesToHexString :: [Word8] -> String
bytesToHexString [] = []
bytesToHexString (x:xs) = byteToHex (x `shiftR` 4 .&. 0xf) : byteToHex (x .&. 0xf) : bytesToHexString xs

hexStringToBase64 :: String -> String
hexStringToBase64 = bytesToBase64 . hexStringToBytes

-- Set 1, Challenge 3: Decrypt single-byte XOR with frequency analysis ---------
fixedXor :: [Word8] -> [Word8] -> [Word8]
fixedXor = zipWith xor

fixedXorHexStr :: String -> String -> String
fixedXorHexStr a b = bytesToHexString $ fixedXor (hexStringToBytes a) (hexStringToBytes b)

-- Decrypt a hex-encoded message with a single-byte XOR
singleXorHexStr s c = bytesToString $ fixedXor (hexStringToBytes s) $ cycle (charToBytes c)

-- English letter frequencies (https://en.wikipedia.org/wiki/Letter_frequency)
charFreqEnglish = M.fromList
  [ ('a', 0.08167)
  , ('b', 0.01492)
  , ('c', 0.02782)
  , ('d', 0.04253)
  , ('e', 0.1270)
  , ('f', 0.02228)
  , ('g', 0.02015)
  , ('h', 0.06094)
  , ('i', 0.06966)
  , ('j', 0.00153)
  , ('k', 0.00772)
  , ('l', 0.04025)
  , ('m', 0.02406)
  , ('n', 0.06749)
  , ('o', 0.07507)
  , ('p', 0.01929)
  , ('q', 0.00095)
  , ('r', 0.05987)
  , ('s', 0.06327)
  , ('t', 0.09056)
  , ('u', 0.02758)
  , ('v', 0.00978)
  , ('w', 0.02361)
  , ('x', 0.00150)
  , ('y', 0.01974)
  , ('z', 0.00074) ]

freqExpected c = M.findWithDefault 0 c charFreqEnglish

-- number of occurences of an element in a list
count :: Eq a => a -> [a] -> Int
count c = length . filter (==c)

-- frequency of an element in a list
freq :: Eq a => [a] -> a -> Double
freq s c = fromIntegral (count c s) / fromIntegral (length s)

-- score for a Char = square deviation from expected frequency
getScore :: String -> Char -> Double
getScore s c = (freq s c - freqExpected c) ^^ 2

-- score an entire string (sum scores for 'a'..'z' and unexpected characters '*')
scoreString :: String -> Double
scoreString s = sum $ map (getScore s') ('*':['a'..'z'])
  where
    s' = map (replaceNonAlpha . toLower) s
    replaceNonAlpha c = if c `elem` ['a'..'z'] then c else '*'

-- Decrypt with every letter, calculate score, and return the result with the lowest score
tryDecryptHex :: String -> String
tryDecryptHex s = snd . minimum $ map ((\s -> (scoreString s, s)) . singleXorHexStr s) ['A'..'Z']