module Happstack.Crypto.W64 where
import Happstack.Crypto.DES
import Happstack.Crypto.SHA1
import Data.List
import Numeric(readHex)
#ifdef TEST
import Test.QuickCheck
#endif
pad :: String -> String
pad x = padding++x
where
padLength = 4 (length x) `mod` 4
padding = (toEnum padLength) : (replicate (padLength1) 'A')
unpad :: (Enum a) => [a] -> [a]
unpad x = drop (fromEnum $ head x) x
prop_PadUnPad :: String -> Bool
prop_PadUnPad x = x==(unpad $ pad x)
is4Char :: [a] -> Bool
is4Char x = length x==4
quadCharToW64 :: (Num b, Enum a) => [a] -> b
quadCharToW64 = fromInteger . impl . map (fromIntegral.fromEnum)
where impl :: [Integer] -> Integer
impl [a,b,c,d]=(a*2^24+b*2^16+c*2^8+d)
impl _ = error "Argument to quadCharToW64 must be length 4"
w64ToQuadChar :: (Integral a, Enum b) => a -> [b]
w64ToQuadChar w64 =
map (toEnum.fromIntegral) $! reverse $! take 4 $! v ++ (repeat 0)
where v = w64ToQuadNum w64
w64ToQuadNum :: (Integral a) => a -> [a]
w64ToQuadNum = unfoldr (\x->if x==0 then Nothing else
Just (x `mod` 256,x `div` 256))
#ifdef TEST
prop_quadCharW64 x = is4Char x ==> x == (w64ToQuadChar $ quadCharToW64 x)
#endif
toQuadChars :: [a] -> [[a]]
toQuadChars [] = []
toQuadChars (a:b:c:d:rest) = [a,b,c,d]:toQuadChars rest
toQuadChars _ = error "Argument for toQuadChars must have a length that is a multiple of 4"
stringToW64s :: (Num a) => String -> [a]
stringToW64s = map quadCharToW64 . toQuadChars . pad
w64sToString :: (Enum b) => [Integer] -> [b]
w64sToString = unpad . concatMap w64ToQuadChar
prop_stringW64 :: String -> Bool
prop_stringW64 x = x == (w64sToString $ stringToW64s x)
hexToW64 :: (Num a) => String -> a
hexToW64 = fromInteger . fst . head . readHex . take 16
stringToKey :: (Num a) => String -> a
stringToKey = hexToW64 . sha1
des_encrypt :: String -> String -> [Enc]
des_encrypt key = map (flip des_enc $ stringToKey key) . stringToW64s
des_decrypt :: (Enum a) => String -> [Message] -> [a]
des_decrypt key =
w64sToString .
map (toInteger . flip des_dec (stringToKey key))
prop_DES :: String -> String -> Bool
prop_DES key val = val == (des_decrypt key $ des_encrypt key val)