Chiffrement par blocs et Haskell

Voici le squlette d'un module servant à étudier les chiffrements par blocs étudiés en cours : ECB, CBC, CFB, César, chiffrement affine. Il ne reste plus qu'à l'étudier et le compléter...

Haskell
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
 
module CryptoSysteme where
 
    import Data.Char (ord,chr)
    import Data.List (sort, dropWhileEnd)
       
    -----------------------------------------------------------------
    -- Classe de types pour manipuler des cryptosystèmes par Blocs
    -----------------------------------------------------------------
    data Bit = O | I deriving (Show, Eq, Ord, Enum)
 
    b_plus :: Bit -> Bit -> Bit
    ...
 
    b_fois :: Bit -> Bit -> Bit
    ...
 
    bitToInteger :: Bit -> Integer
    ...
                     
    instance Num Bit where
            (+) = ...
            (*) = ...
            negate x = x
            fromInteger 0 = O
            fromInteger 1 = I
            fromInteger k = fromInteger (k `mod` 2)
            abs x = x
            signum _ = 1
                  
    -- Blocs de bits de longueur fixée par le cryptosystème
    type Bloc = [Bit] 
        
    class Cryptosys cle where
                     longBloc     :: cle -> Int
                     encryptBloc  :: cle -> Bloc -> Bloc
                     decryptBloc  :: cle -> Bloc -> Bloc
                             
    decoupeEnBlocs :: Int -> [Bit] -> [Bloc]
    decoupeEnBlocs    _      []  = []
    decoupeEnBlocs    n      xs  
        | (length xs) < n = [xs ++ [O | _ <- [1 .. n - (length xs)]]]
        | otherwise =
        paquet : (decoupeEnBlocs n paquets)
            where (paquet,paquets) = splitAt n xs
                             
    enleveEspacesFin :: String -> String
    enleveEspacesFin = dropWhileEnd (== ' ') 
                                                                          
    blocsToString :: [Bloc] -> String
    blocsToString    bs     =
        enleveEspacesFin $ map (chr'.toDec) (decoupeEnBlocs 7 (concat bs))
 
    stringToBlocs :: (Cryptosys cle) => cle -> String -> [Bloc]
    stringToBlocs                       key    cs     =
                     decoupeEnBlocs (longBloc key) $ concat $ map (toBin.ord') cs  
                             
    encryptStr :: (Cryptosys cle) => cle -> String -> String
    encryptStr                       kle    cs     =
        blocsToString $ map (encryptBloc kle) (stringToBlocs kle cs)   
 
    decryptStr :: (Cryptosys cle) => cle -> String -> String
    ...
 
    messageTest :: String
    messageTest = map chr' [0..127]
                                                      
    testCrypto :: (Cryptosys cle) => cle -> Bool
    testCrypto                       key =
                     decryptStr key (encryptStr key messageTest) == messageTest
                                                      
    ------------------------------------------------------------------                                             
    -- Code César : cryptosystème par blocs de 7 bits
    ------------------------------------------------------------------
 
    type Cesar = Integer                                            
                                                 
    decaleCesar :: Cesar -> Bloc -> Bloc
    ...
    
    instance Cryptosys Cesar where
                   ...
                   ...
                   ...
             
    cleCesar :: Cesar
    cleCesar =  3
 
    
               
    --------------------------------------------------------------------
    -- Code Affine : cryptosystème par blocs de 7 bits
    --------------------------------------------------------------------
 
    -- une clé affine est la donnée de deux entiers
    type Affine = (Integer,Integer)    
 
    -- crypte = a * clair + b
    decaleAffine :: Affine -> Bloc -> Bloc
    ...
 
    -- algo d'euclide étendu : retourne [u,v,pgcd a n]
    euclide :: Integer -> Integer -> [Integer]
    euclide    a      n   =
       ...
 
    -- calcule de l'inverse de a modulo n
    invMod :: Integer -> Integer -> Integer
    invMod    a      n   =
        ...
 
    -- clair = (crypte - b) * a^(-1)
    recaleAffine :: Affine -> Bloc -> Bloc
    recaleAffine    cle       c    =
        ...
            
 
    instance Cryptosys Affine where
             ...
             ...
             ...
 
    cleAff :: Affine
    cleAff =  (17,22)
 
    ------------------------------------------------------------------------
    -- ECB : cryptosystème par blocs de taille variable
    ------------------------------------------------------------------------
 
    -- une permutation sur [0,n] est donnée par les images de [0,n]
    type Permut = [Int]
 
 
    -- ECB est défini par la donnée d'une permutation
    type ECB = Permut
                     
    -- Permutation d'un bloc de bits
    permutBloc :: Permut -> Bloc -> Bloc
    permutBloc    perm      bs   =  [... | ...]                             
 
    -- Renvoie la réciproque d'une permutation
    invPermut :: Permut -> Permut
    invPermut    perm   =
                     map snd $ sort $ zip perm [0 .. (length perm - 1)]
 
    instance Cryptosys ECB where
                     ...
                     ...
                     ...
 
    cleEcb :: ECB
    cleEcb = [2,0,3,1,5,4,6]
 
    cleEcb' :: ECB
    cleEcb' = [2,0,3,1]
 
 
    ------------------------------------------------------------------------
    -- CBC : cryptosystème par blocs chaînés de taille variable
    ------------------------------------------------------------------------
    ...
 
    
    ------------------------------------------------------------------------
    -- CFB : cryptosystème par blocs chaînés avec registre de décalage
    ------------------------------------------------------------------------
    ...
                     
    -------------------------------------------------------------------
    -- Français sous 7 bits
    -- On écrase les touches d'action avec les lettres accentuées 
    -------------------------------------------------------------------
 
    -- Réécrit un bloc de n bits en un bloc de 7 bits en rajoutant d'éventuels O à gauche
    -- Un bloc de longueur supérieur à 7 est tronqué
    septBits :: Bloc -> Bloc
    ...
 
    -- convertit un entier modulo 128 en un bloc de 7 bits
    toBin :: Integer -> Bloc
    ...
 
    -- convertir un bloc de 7 bits en un entier 
    toDec :: Bloc -> Integer
    ...
 
    -- remape la table ASCII pour avoir des caractères dans [0,127] et l'espace vaut 0
    chr' :: Integer -> Char
    chr' 0  = ' '
    chr' 32 = 'à'
    chr' 1  = 'â'
    chr' 2  = 'é'
    chr' 3  = 'è'
    chr' 4  = 'ê'
    chr' 5  = 'ë'
    chr' 6  = 'î'
    chr' 7  = 'ï'
    chr' 8  = 'ô'
    chr' 9  = 'ö'
    chr' 10 = 'ù'
    chr' 11 = 'û'
    chr' 12 = 'ü'
    chr' 13 = 'ç'
    chr' 14 = 'æ'
    chr' 15 = 'œ'
    chr' 16 = 'À'
    chr' 17 = 'Â'
    chr' 18 = 'É'
    chr' 19 = 'È'
    chr' 20 = 'Ê'
    chr' 21 = 'Ë'
    chr' 22 = 'Î'
    chr' 23 = 'Ï'
    chr' 24 = 'Ô'
    chr' 25 = 'Ö'
    chr' 26 = 'Ù'
    chr' 27 = 'Û'
    chr' 28 = 'Ü'
    chr' 29 = 'Ç'
    chr' 30 = 'Æ'
    chr' 31 = 'Œ'
    chr' 127 = '€'
    chr' x   = chr (fromInteger x) 
 
 
    ord' :: Char -> Integer
    ord'  'à' = 32
    ord'  ' ' = 0
    ord'  'â' = 1
    ord'  'é' = 2
    ord'  'è' = 3
    ord'  'ê' = 4
    ord'  'ë' = 5
    ord'  'î' = 6
    ord'  'ï' = 7
    ord'  'ô' = 8 
    ord'  'ö' = 9 
    ord'  'ù' = 10
    ord'  'û' = 11
    ord'  'ü' = 12 
    ord'  'ç' = 13
    ord'  'æ' = 14
    ord'  'œ' = 15
    ord'  'À' = 16
    ord'  'Â' = 17
    ord'  'É' = 18
    ord'  'È' = 19
    ord'  'Ê' = 20
    ord'  'Ë' = 21
    ord'  'Î' = 22
    ord'  'Ï' = 23
    ord'  'Ô' = 24
    ord'  'Ö' = 25
    ord'  'Ù' = 26
    ord'  'Û' = 27
    ord'  'Ü' = 28
    ord'  'Ç' = 29
    ord'  'Æ' = 30
    ord'  'Œ' = 31
    ord'  '€' = 127
    ord'   x  = fromIntegral (ord x)

Par exemple:

Haskell
λ> O + I
I
λ> toBin 13
[O,O,O,I,I,O,I]
λ> toDec [I,O,I]
5
λ> septBits [I,O,I]
[O,O,O,O,I,O,I]
λ> stringToBlocs cleCesar "ab"
[[I,I,O,O,O,O,I],[I,I,O,O,O,I,O]]
λ> stringToBlocs cleAff "ab"
[[I,I,O,O,O,O,I],[I,I,O,O,O,I,O]]
λ> stringToBlocs cleEcb' "ab"
[[I,I,O,O],[O,O,I,I],[I,O,O,O],[I,O,O,O]]
λ> encryptStr cleCesar "Toute la Gaule est envahie ! Toute ? Toute !"
"Wrxwh\232od\232Jdxoh\232hvw\232hqydklh\232$\232Wrxwh\232B\232Wrxwh\232$"
λ> putStrLn $ encryptStr cleCesar "Toute la Gaule est envahie ! Toute ? Toute !"
WrxwhèodèJdxohèhvwèhqydklhè$èWrxwhèBèWrxwhè$
λ> putStrLn $ encryptStr cleAff "Toute la Gaule est envahie ! Toute ? Toute !"
*u[JKÎBïÎMï[BKÎK9JÎKdlï~œKÎGÎ*u[JKÎEÎ*u[JKÎG
λ> putStrLn $ encryptStr cleEcb "Toute la Gaule est envahie ! Toute ? Toute !"
b?kj+ :) ')k:+ +mj +>n)89+ ö b?kj+ _ b?kj+ ö
λ> putStrLn $ encryptStr cleEcb' "Toute la Gaule est envahie ! Toute ? Toute !"
c;yq.éSÉâûas!Èm\âÈ;_AT=Ô!éâæWskÔ!/âæWskÔ!é
λ> putStrLn $ encryptStr cleCesar "aaaaaaaabbbbbbbb"
ddddddddeeeeeeee
λ> putStrLn $ encryptStr cleAff "aaaaaaaabbbbbbbb"
ïïïïïïïïÔÔÔÔÔÔÔÔ
λ> putStrLn $ encryptStr cleEcb "aaaaaaaabbbbbbbb"
)))))))),,,,,,,,
λ> putStrLn $ encryptStr cleEcb' "aaaaaaaabbbbbbbb"
-ÉaR-ÉaR)SEÔ)SEÔ

courtesy of webmatter.de