diff --git a/happstack-util.cabal b/happstack-util.cabal --- a/happstack-util.cabal +++ b/happstack-util.cabal @@ -1,6 +1,6 @@ Cabal-version: >=1.2.3 Name: happstack-util -Version: 0.1 +Version: 0.2.1 Synopsis: Web framework License: BSD3 License-file: COPYING @@ -16,12 +16,23 @@ Flag tests Description: Build the testsuite, and include the tests in the library - Default: True + Default: False Library - Build-Depends: mtl, hslogger >= 1.0.2, template-haskell, array, - bytestring, old-time, process, directory, extensible-exceptions, - HUnit, QuickCheck, random + Build-Depends: array, + bytestring, + directory, + extensible-exceptions, + hslogger >= 1.0.2, + mtl, + old-locale, + old-time, + parsec < 3, + process, + time, + QuickCheck < 2, + random, + template-haskell if flag(base4) Build-Depends: base >= 4 else @@ -31,21 +42,25 @@ if flag(tests) hs-source-dirs: tests Exposed-modules: - HAppS.Crypto.Base64, - HAppS.Crypto.DES, - HAppS.Crypto.HMAC, - HAppS.Crypto.SHA1, - HAppS.Crypto.MD5, - HAppS.Crypto.W64, - HAppS.Util.ByteStringCompat, - HAppS.Util.Common, - HAppS.Util.Concurrent, - HAppS.Util.Daemonize, - HAppS.Util.TimeOut, - HAppS.Util.TH, - HAppS.Util.Testing + Happstack.Crypto.Base64, + Happstack.Crypto.DES, + Happstack.Crypto.HMAC, + Happstack.Crypto.SHA1, + Happstack.Crypto.MD5, + Happstack.Crypto.W64, + Happstack.Util.ByteStringCompat, + Happstack.Util.Common, + Happstack.Util.Concurrent, + Happstack.Util.Cron, + Happstack.Util.Daemonize, + Happstack.Util.HostAddress, + Happstack.Util.LogFormat, + Happstack.Util.TimeOut, + Happstack.Util.TH, + Happstack.Util.Testing if flag(tests) - Exposed-modules: HAppS.Util.Tests + Exposed-modules: Happstack.Util.Tests + Exposed-modules: Happstack.Util.Tests.HostAddress extensions: CPP, UndecidableInstances, BangPatterns, StandaloneDeriving, DeriveDataTypeable, TemplateHaskell, RecursiveDo @@ -59,6 +74,7 @@ hs-source-dirs: tests, src if flag(tests) Buildable: True + Build-Depends: network else Buildable: False diff --git a/src/HAppS/Crypto/Base64.hs b/src/HAppS/Crypto/Base64.hs deleted file mode 100644 --- a/src/HAppS/Crypto/Base64.hs +++ /dev/null @@ -1,139 +0,0 @@ --- BSDLicensed --- Copyright (c) 2002, Warrick Gray All rights reserved. --- See http://www.ietf.org/rfc/rfc2045.txt for definition. -module HAppS.Crypto.Base64 ( - encode, - decode, - chop72 -) where - -{- - -The following properties should hold: - - decode . encode = id - decode . chop72 . encode = id - -I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, -the second variation corresponds better with the RFC above, but outside of -MIME applications might be undesireable. - - - -But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only - 8 significant bits, which is more than enough for US-ASCII. --} - - - - -import Data.Array.Unboxed -import Data.Bits -import Data.Int -import Data.Char (chr,ord) - - -encodeArray :: UArray Int Char -encodeArray = array (0,64) - [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') - , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') - , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') - , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') - , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') - , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') - , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') - , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') - , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') - , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') - , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] - - --- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) --- clearly the upmost/leftmost 8 bits of the answer are 0. --- Hack Alert: In the last entry of the answer, the upper 8 bits encode --- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. --- 0 represents a 4 :( -int4_char3 :: [Int] -> [Char] -int4_char3 (a:b:c:d:t) = - let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) - in (chr (n `shiftR` 16 .&. 0xff)) - : (chr (n `shiftR` 8 .&. 0xff)) - : (chr (n .&. 0xff)) : int4_char3 t - -int4_char3 [a,b,c] = - let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) - in [ (chr (n `shiftR` 16 .&. 0xff)) - , (chr (n `shiftR` 8 .&. 0xff)) ] - -int4_char3 [a,b] = - let n = (a `shiftL` 18 .|. b `shiftL` 12) - in [ (chr (n `shiftR` 16 .&. 0xff)) ] - -int4_char3 [] = [] -int4_char3 _ = error "Case not implemented in int4_char3" - - - --- Convert triplets of characters to --- 4 base64 integers. The last entries --- in the list may not produce 4 integers, --- a trailing 2 character group gives 3 integers, --- while a trailing single character gives 2 integers. -char3_int4 :: [Char] -> [Int] -char3_int4 (a:b:c:t) - = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) - in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t - -char3_int4 [a,b] - = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) - in [ (n `shiftR` 18 .&. 0x3f) - , (n `shiftR` 12 .&. 0x3f) - , (n `shiftR` 6 .&. 0x3f) ] - -char3_int4 [a] - = let n = (ord a `shiftL` 16) - in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] - -char3_int4 [] = [] - - --- Retrieve base64 char, given an array index integer in the range [0..63] -enc1 :: Int -> Char -enc1 ch = encodeArray!ch - - --- | Cut up a string into 72 char lines, each line terminated by CRLF. -chop72 :: String -> String -chop72 str = let (bgn,end) = splitAt 70 str - in if null end then bgn else bgn ++ "\r\n" ++ chop72 end - - --- Pads a base64 code to a multiple of 4 characters, using the special --- '=' character. -quadruplets :: String -> String -quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t -quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit -quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit -quadruplets [] = [] -- 24bit tail unit -quadruplets _ = error "Case not implemented in quadruplets" - -enc :: [Int] -> [Char] -enc = quadruplets . map enc1 - - -dcd :: String -> [Int] -dcd [] = [] -dcd (h:t) - | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t - | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t - | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t - | h == '+' = 62 : dcd t - | h == '/' = 63 : dcd t - | h == '=' = [] -- terminate data stream - | otherwise = dcd t - - --- Principal encoding and decoding functions. -encode, decode :: String -> String -encode = enc . char3_int4 -decode = int4_char3 . dcd diff --git a/src/HAppS/Crypto/DES.lhs b/src/HAppS/Crypto/DES.lhs deleted file mode 100644 --- a/src/HAppS/Crypto/DES.lhs +++ /dev/null @@ -1,287 +0,0 @@ -> {-# LANGUAGE FlexibleInstances #-} -> {-# OPTIONS -fno-warn-missing-methods #-} - - -{-- -Copyright (C) 2001 Ian Lynagh - -DES.lhs can be used under either the BSD or GPL. - -http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ - -Copyright (c) The Regents of the University of California. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. 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. -3. Neither the name of the University nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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. ---} - - -> module HAppS.Crypto.DES (des_enc, des_dec, Message, Enc) where - -> import Data.Bits -> import Data.Word - -more stuff just copied in - -> import Numeric - --- added by alex - -> data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) - -> w64ToInteger :: Zord64 -> Integer -> w64ToInteger W64{lo=l,hi=h} = toInteger l + 0x100000000 * toInteger h -> integerToW64 :: Integer -> Zord64 -> integerToW64 x = case x `quotRem` 0x100000000 of -> (h,l) -> W64{lo=fromInteger l, hi=fromInteger h} - -> instance Show Zord64 where -> showsPrec _ = showInt . w64ToInteger - -> instance Read Zord64 where -> readsPrec _ s = [ (integerToW64 x,r) | (x,r) <- readDec s ] - -> instance Num Zord64 where -> W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a + lo_b -> hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0 -> fromInteger = integerToW64 - -Added by alex - -> signum 0 = 0 -> signum _ = 1 -> x * y = integerToW64 $ (w64ToInteger x) * (w64ToInteger y) - - -> instance Bits Zord64 where -> W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a .&. lo_b -> hi' = hi_a .&. hi_b -> W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a .|. lo_b -> hi' = hi_a .|. hi_b -> shift w 0 = w -> shift W64{lo=l,hi=h} x -> | x > 63 = W64{lo=0,hi=0} -> | x > 31 = W64{lo = 0, hi = shift l (x-32)} -> | x > 0 = W64{lo = shift l x, hi = shift h x .|. shift l (x-32)} -> shift _ _ = error "Case not defined in Bits instance for Zord64" - -> instance Integral Zord64 where -> toInteger = w64ToInteger - -added by alex - -> quotRem numer divis = -> let (d,r)= quotRem (w64ToInteger numer) (w64ToInteger divis) -> in (fromInteger d,fromInteger r) - -> instance Real Zord64 -> instance Enum Zord64 - ---simplifying so we don't need all the hugs decls. - - -> type Rotation = Int -> type Key = Zord64 -> type Message = Zord64 -> type Enc = Zord64 - -> -- type BitsX = [Bool] -> type Bits4 = [Bool] -> type Bits6 = [Bool] -> type Bits32 = [Bool] -> type Bits48 = [Bool] -> type Bits56 = [Bool] -> type Bits64 = [Bool] - - - -> instance Num [Bool] where {} - - - -> instance Bits [Bool] where -> a `xor` b = (zipWith (\x y -> (not x && y) || (x && not y)) a b) -> rotate bits rot = drop rot' bits ++ take rot' bits -> where rot' = rot `mod` (length bits) - -> bitify :: Zord64 -> Bits64 -> bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] - -> unbitify :: Bits64 -> Zord64 - -Added by Alex - -> unbitify bs = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs - -> initial_permutation :: Bits64 -> Bits64 -> initial_permutation mb = map ((!!) mb) i -> where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, -> 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, -> 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, -> 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] - -> key_transformation :: Bits64 -> Bits56 -> key_transformation kb = map ((!!) kb) i -> where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, -> 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, -> 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, -> 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] - -> des_enc :: Message -> Key -> Enc -> des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] - -> des_dec :: Message -> Key -> Enc -> des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] - -> do_des :: [Rotation] -> Message -> Key -> Enc -> do_des rots m k = des_work rots (takeDrop 32 mb) kb -> where kb = key_transformation $ bitify k -> mb = initial_permutation $ bitify m - -> des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc -> des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) -> des_work (r:rs) mb kb = des_work rs mb' kb -> where mb' = do_round r mb kb - -> do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) -> do_round r (ml, mr) kb = (mr, m') -> where kb' = get_key kb r -> comp_kb = compression_permutation kb' -> expa_mr = expansion_permutation mr -> res = comp_kb `xor` expa_mr -> res' = tail $ iterate (trans 6) ([], res) -> trans n (_, b) = (take n b, drop n b) -> res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, -> s_box_3, s_box_4, -> s_box_5, s_box_6, -> s_box_7, s_box_8] res' -> res_p = p_box res_s -> m' = res_p `xor` ml - -> get_key :: Bits56 -> Rotation -> Bits56 -> get_key kb r = kb' -> where (kl, kr) = takeDrop 28 kb -> kb' = rotateL kl r ++ rotateL kr r - -> compression_permutation :: Bits56 -> Bits48 -> compression_permutation kb = map ((!!) kb) i -> where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, -> 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, -> 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, -> 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] - -> expansion_permutation :: Bits32 -> Bits48 -> expansion_permutation mb = map ((!!) mb) i -> where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, -> 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, -> 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, -> 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] - -> s_box :: [[Word8]] -> Bits6 -> Bits4 -> s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col -> where row = sum $ zipWith numericise [a,f] [1, 0] -> col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] -> numericise = (\x y -> if x then 2^y else 0) -> to_bool 0 _ = [] -> to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) -> s_box _ _ = error "second arg to s_box must have length 6" - -> s_box_1 :: Bits6 -> Bits4 -> s_box_1 = s_box i -> where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], -> [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], -> [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], -> [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] - -> s_box_2 :: Bits6 -> Bits4 -> s_box_2 = s_box i -> where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], -> [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], -> [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], -> [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] - -> s_box_3 :: Bits6 -> Bits4 -> s_box_3 = s_box i -> where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], -> [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], -> [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], -> [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] - -> s_box_4 :: Bits6 -> Bits4 -> s_box_4 = s_box i -> where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], -> [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], -> [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], -> [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] - -> s_box_5 :: Bits6 -> Bits4 -> s_box_5 = s_box i -> where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], -> [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], -> [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], -> [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] - -> s_box_6 :: Bits6 -> Bits4 -> s_box_6 = s_box i -> where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], -> [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], -> [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], -> [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] - -> s_box_7 :: Bits6 -> Bits4 -> s_box_7 = s_box i -> where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], -> [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], -> [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], -> [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] - -> s_box_8 :: Bits6 -> Bits4 -> s_box_8 = s_box i -> where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], -> [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], -> [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], -> [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] - -> p_box :: Bits32 -> Bits32 -> p_box kb = map ((!!) kb) i -> where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, -> 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] - -> final_perm :: Bits64 -> Bits64 -> final_perm kb = map ((!!) kb) i -> where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, -> 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, -> 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, -> 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] - -> takeDrop :: Int -> [a] -> ([a], [a]) -> takeDrop _ [] = ([], []) -> takeDrop 0 xs = ([], xs) -> takeDrop n (x:xs) = (x:ys, zs) -> where (ys, zs) = takeDrop (n-1) xs - diff --git a/src/HAppS/Crypto/HMAC.hs b/src/HAppS/Crypto/HMAC.hs deleted file mode 100644 --- a/src/HAppS/Crypto/HMAC.hs +++ /dev/null @@ -1,18 +0,0 @@ -module HAppS.Crypto.HMAC where - -import HAppS.Crypto.SHA1 -import HAppS.Crypto.Base64 - -import Data.Bits -import Data.Char - -hmacSHA1 :: String -> String -> String -hmacSHA1 key str - | length key > b = fail "hmacSHA1 doesn't support large keys yet" - | otherwise - = encode $ sha1Raw (doxor key opad ++ sha1Raw (doxor key ipad ++ str)) - where b = 64 - opad = replicate b '\x5C' - ipad = replicate b '\x36' - doxor a = zipWith fn (a++repeat '\0') - fn x y = chr (ord x `xor` ord y) diff --git a/src/HAppS/Crypto/MD5.hs b/src/HAppS/Crypto/MD5.hs deleted file mode 100644 --- a/src/HAppS/Crypto/MD5.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -funbox-strict-fields -fvia-c -optc-funroll-all-loops -optc-O3 #-} --- --- Module : HAppS.Crypto.MD5 --- License : BSD3 --- Maintainer : lemmih@vo.com --- Author : Thomas.DuBuisson@mail.google.com --- Stability : experimental --- Portability : portable, requires bang patterns and ByteString --- Tested with : GHC-6.8.1 --- - -module HAppS.Crypto.MD5 - (md5 - ,md5InitialContext - ,md5Update - ,md5Finalize - ,MD5Context - ,md5File - ,stringMD5 - ,applyMD5Rounds - ,test - ) where - -import Prelude hiding ((!!)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal -import Data.Bits -import Data.List hiding ((!!)) -import Data.Int(Int64) -import Data.Word -import Foreign.Storable -import Foreign.Ptr -import Foreign.ForeignPtr -import Numeric -import System.Environment() -import System.IO - -blockSize :: Int -blockSize = 512 -- Block size in bits - -blockSizeBytes :: Int -blockSizeBytes = blockSize `div` 8 - -blockSizeBytesW64 :: Int64 -blockSizeBytesW64 = fromIntegral blockSizeBytes - -blockSizeBits :: Word64 -blockSizeBits = fromIntegral blockSize - -data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 -data MD5Context = MD5Ctx { mdPartial :: MD5Partial, - mdLeftOver :: ByteString, - mdTotalLen :: Word64 - } - -md5InitialContext :: MD5Context -md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 -h0, h1, h2, h3 :: Word32 -h0 = 0x67452301 -h1 = 0xEFCDAB89 -h2 = 0x98BADCFE -h3 = 0x10325476 - --- | Will read the lazy ByteString and return the md5 digest. --- Some application might want to wrap this function for type safty. -md5 :: L.ByteString -> L.ByteString -md5 bs = md5Finalize $ md5Update md5InitialContext bs - -md5Finalize :: MD5Context -> L.ByteString -md5Finalize !ctx@(MD5Ctx (MD5Par _ _ _ _) r !totLen) = - let totLen' = (totLen + 8*fromIntegral l) :: Word64 - padBS = B.pack $ 0x80 : replicate lenZeroPad 0 ++ size_split 8 totLen' - - (MD5Ctx (MD5Par a' b' c' d') _ _) = md5Update ctx (L.fromChunks [r,padBS]) - in L.pack $ concatMap (size_split 4) [a',b',c',d'] - where - l = B.length r - lenZeroPad = if (l+1) <= blockSizeBytes - 8 - then (blockSizeBytes - 8) - (l+1) - else (2*blockSizeBytes - 8) - (l+1) - -size_split :: (Integral t, Num a) => Int -> t -> [a] -size_split 0 _ = [] -size_split p n = (fromIntegral d):size_split (p-1) n' - where (n', d) = divMod n 256 - -md5Update :: MD5Context -> L.ByteString -> MD5Context -md5Update ctx bsLazy = - let _ = L.toChunks bsLazy - blks = block bsLazy - in foldl' performMD5Update ctx blks - -block :: L.ByteString -> [ByteString] -block bs = case L.toChunks bs of - [] -> [] - _ -> (B.concat . L.toChunks) top : block rest - where - (top,rest) = L.splitAt blockSizeBytesW64 bs -{-# INLINE block #-} - --- Assumes ByteString length == blockSizeBytes, will fold the --- context across calls to applyMD5Rounds. -performMD5Update :: MD5Context -> ByteString -> MD5Context -performMD5Update !ctx@(MD5Ctx !par@(MD5Par !a !b !c !d) _ !len) bs = - let MD5Par a' b' c' d' = applyMD5Rounds par bs - in if B.length bs == blockSizeBytes - then MD5Ctx { - mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), - mdLeftOver = B.empty, - mdTotalLen = len + blockSizeBits - } - else ctx { mdLeftOver = bs } - -applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial -applyMD5Rounds (MD5Par a b c d) w = - let -- Round 1 - !r0 = ff a b c d (w!!0) 7 3614090360 - !r1 = ff d r0 b c (w!!1) 12 3905402710 - !r2 = ff c r1 r0 b (w!!2) 17 606105819 - !r3 = ff b r2 r1 r0 (w!!3) 22 3250441966 - !r4 = ff r0 r3 r2 r1 (w!!4) 7 4118548399 - !r5 = ff r1 r4 r3 r2 (w!!5) 12 1200080426 - !r6 = ff r2 r5 r4 r3 (w!!6) 17 2821735955 - !r7 = ff r3 r6 r5 r4 (w!!7) 22 4249261313 - !r8 = ff r4 r7 r6 r5 (w!!8) 7 1770035416 - !r9 = ff r5 r8 r7 r6 (w!!9) 12 2336552879 - !r10 = ff r6 r9 r8 r7 (w!!10) 17 4294925233 - !r11 = ff r7 r10 r9 r8 (w!!11) 22 2304563134 - !r12 = ff r8 r11 r10 r9 (w!!12) 7 1804603682 - !r13 = ff r9 r12 r11 r10 (w!!13) 12 4254626195 - !r14 = ff r10 r13 r12 r11 (w!!14) 17 2792965006 - !r15 = ff r11 r14 r13 r12 (w!!15) 22 1236535329 - -- Round 2 - !r16 = gg r12 r15 r14 r13 (w!!1) 5 4129170786 - !r17 = gg r13 r16 r15 r14 (w!!6) 9 3225465664 - !r18 = gg r14 r17 r16 r15 (w!!11) 14 643717713 - !r19 = gg r15 r18 r17 r16 (w!!0) 20 3921069994 - !r20 = gg r16 r19 r18 r17 (w!!5) 5 3593408605 - !r21 = gg r17 r20 r19 r18 (w!!10) 9 38016083 - !r22 = gg r18 r21 r20 r19 (w!!15) 14 3634488961 - !r23 = gg r19 r22 r21 r20 (w!!4) 20 3889429448 - !r24 = gg r20 r23 r22 r21 (w!!9) 5 568446438 - !r25 = gg r21 r24 r23 r22 (w!!14) 9 3275163606 - !r26 = gg r22 r25 r24 r23 (w!!3) 14 4107603335 - !r27 = gg r23 r26 r25 r24 (w!!8) 20 1163531501 - !r28 = gg r24 r27 r26 r25 (w!!13) 5 2850285829 - !r29 = gg r25 r28 r27 r26 (w!!2) 9 4243563512 - !r30 = gg r26 r29 r28 r27 (w!!7) 14 1735328473 - !r31 = gg r27 r30 r29 r28 (w!!12) 20 2368359562 - -- Round 3 - !r32 = hh r28 r31 r30 r29 (w!!5) 4 4294588738 - !r33 = hh r29 r32 r31 r30 (w!!8) 11 2272392833 - !r34 = hh r30 r33 r32 r31 (w!!11) 16 1839030562 - !r35 = hh r31 r34 r33 r32 (w!!14) 23 4259657740 - !r36 = hh r32 r35 r34 r33 (w!!1) 4 2763975236 - !r37 = hh r33 r36 r35 r34 (w!!4) 11 1272893353 - !r38 = hh r34 r37 r36 r35 (w!!7) 16 4139469664 - !r39 = hh r35 r38 r37 r36 (w!!10) 23 3200236656 - !r40 = hh r36 r39 r38 r37 (w!!13) 4 681279174 - !r41 = hh r37 r40 r39 r38 (w!!0) 11 3936430074 - !r42 = hh r38 r41 r40 r39 (w!!3) 16 3572445317 - !r43 = hh r39 r42 r41 r40 (w!!6) 23 76029189 - !r44 = hh r40 r43 r42 r41 (w!!9) 4 3654602809 - !r45 = hh r41 r44 r43 r42 (w!!12) 11 3873151461 - !r46 = hh r42 r45 r44 r43 (w!!15) 16 530742520 - !r47 = hh r43 r46 r45 r44 (w!!2) 23 3299628645 - -- Round 4 - !r48 = ii r44 r47 r46 r45 (w!!0) 6 4096336452 - !r49 = ii r45 r48 r47 r46 (w!!7) 10 1126891415 - !r50 = ii r46 r49 r48 r47 (w!!14) 15 2878612391 - !r51 = ii r47 r50 r49 r48 (w!!5) 21 4237533241 - !r52 = ii r48 r51 r50 r49 (w!!12) 6 1700485571 - !r53 = ii r49 r52 r51 r50 (w!!3) 10 2399980690 - !r54 = ii r50 r53 r52 r51 (w!!10) 15 4293915773 - !r55 = ii r51 r54 r53 r52 (w!!1) 21 2240044497 - !r56 = ii r52 r55 r54 r53 (w!!8) 6 1873313359 - !r57 = ii r53 r56 r55 r54 (w!!15) 10 4264355552 - !r58 = ii r54 r57 r56 r55 (w!!6) 15 2734768916 - !r59 = ii r55 r58 r57 r56 (w!!13) 21 1309151649 - !r60 = ii r56 r59 r58 r57 (w!!4) 6 4149444226 - !r61 = ii r57 r60 r59 r58 (w!!11) 10 3174756917 - !r62 = ii r58 r61 r60 r59 (w!!2) 15 718787259 - !r63 = ii r59 r62 r61 r60 (w!!9) 21 3951481745 - in MD5Par r60 r63 r62 r61 - where - f !x !y !z = (x .&. y) .|. ((complement x) .&. z) - {-# INLINE f #-} - g !x !y !z = (x .&. z) .|. (y .&. (complement z)) - {-# INLINE g #-} - h !x !y !z = (x `xor` y `xor` z) - {-# INLINE h #-} - i !x !y !z = y `xor` (x .|. (complement z)) - {-# INLINE i #-} - ff a_ b_ c_ d_ x s ac = {-# SCC "ff" #-} - let !a' = f b_ c_ d_ + x + ac + a_ - !a'' = rotateL a' s - in a'' + b_ - {-# INLINE ff #-} - gg a_ b_ c_ d_ x s ac = {-# SCC "gg" #-} - let !a' = g b_ c_ d_ + x + ac + a_ - !a'' = rotateL a' s - in a'' + b_ - {-# INLINE gg #-} - hh a_ b_ c_ d_ x s ac = {-# SCC "hh" #-} - let !a' = h b_ c_ d_ + x + ac + a_ - !a'' = rotateL a' s - in a'' + b_ - {-# INLINE hh #-} - ii a_ b_ c_ d_ x s ac = {-# SCC "ii" #-} - let !a' = i b_ c_ d_ + x + ac + a_ - !a'' = rotateL a' s - in a'' + b_ - {-# INLINE ii #-} - (!!) word32s pos = getNthWord pos word32s - {-# INLINE (!!) #-} - - getNthWord n (PS ptr off _) = - inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do - let p = castPtr $ plusPtr ptr' off - peekElemOff p n - {-# INLINE getNthWord #-} -{-# INLINE applyMD5Rounds #-} - -stringMD5 :: L.ByteString -> String -stringMD5 lazy = - let x = L.toChunks lazy - w = B.unpack (B.concat x) - s = map (\v -> showHex v "") w - s' = map (\v -> if length v == 1 then '0':v else v) s - in concat s' - -test :: IO () -test = do - let h = md5 $ L.pack [] - putStrLn $ "Hash is: " ++ (stringMD5 h) - putStrLn $ "Should Be: d41d8cd98f00b204e9800998ecf8427e" - -md5File :: String -> IO () -md5File f = do - h <- openFile f ReadMode - s <- L.hGetContents h - let hash = md5 s - putStrLn (stringMD5 hash) - return () - diff --git a/src/HAppS/Crypto/SHA1.lhs b/src/HAppS/Crypto/SHA1.lhs deleted file mode 100644 --- a/src/HAppS/Crypto/SHA1.lhs +++ /dev/null @@ -1,165 +0,0 @@ -{-- -Copyright (C) 2001 Ian Lynagh - -SHA.lhs can be used under either the BSD or GPL. - -http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ - -Copyright (c) The Regents of the University of California. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. 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. -3. Neither the name of the University nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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. ---} - -> module HAppS.Crypto.SHA1 (sha1, sha1Raw, sha1_size) where - -> import Data.Char -> import Data.Bits -> import Data.Word - -> type ABCDE = (Word32, Word32, Word32, Word32, Word32) -> type XYZ = (Word32, Word32, Word32) -> type Rotation = Int - -> sha1 :: String -> String -> sha1 s = s5 -> where s1_2 = sha1_step_1_2_pad_length s -> abcde = sha1_step_3_init -> abcde' = sha1_step_4_main abcde s1_2 -> s5 = sha1_step_5_display abcde' - -> sha1Raw :: String -> String -> sha1Raw s = s5 -> where s1_2 = sha1_step_1_2_pad_length s -> abcde = sha1_step_3_init -> abcde' = sha1_step_4_main abcde s1_2 -> s5 = sha1_step_5_concat abcde' - -> sha1_size :: (Integral a) => a -> String -> String -> sha1_size l s = s5 -> where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64))) "" -> abcde = sha1_step_3_init -> abcde' = sha1_step_4_main abcde s1_2 -> s5 = sha1_step_5_display abcde' - -> sha1_step_1_2_pad_length :: String -> String -> sha1_step_1_2_pad_length s = sha1_step_1_2_work 0 s - -> sha1_step_1_2_work :: Integer -> String -> String -> sha1_step_1_2_work c64 "" = padding ++ len -> where padding = '\128':replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) '\000' -> len = map chr $ size_split 8 c64 -> sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work ((c64 + 8) `mod` (2^64)) cs - -> replicate' :: Word16 -> a -> [a] -> replicate' 0 _ = [] -> replicate' n x = x:replicate' (n-1) x - -> size_split :: Int -> Integer -> [Int] -> size_split 0 _ = [] -> size_split p n = size_split (p-1) n' ++ [fromIntegral d] -> where (n', d) = divMod n 256 - -> sha1_step_3_init :: ABCDE -> sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0) - -[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] - -wm3 = [13,14,15] -wm8 = [8,9,10,11,12,13,14,15] -wm14 = [2,3,4,5,6,7,8,9,10,11,12,13,14,15] -wm16 = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] - -> sha1_step_4_main :: ABCDE -> String -> ABCDE -> sha1_step_4_main abcde "" = {- abcde -} abcde -> sha1_step_4_main abcde0 s = sha1_step_4_main abcde5 s' -> where (s64, s') = takeDrop 64 s -> s16 = get_word_32s s64 -> s80 = s16 ++ sha1_add_ws 16 (drop 13 s16, drop 8 s16, drop 2 s16, s16) -> (s20_0, s60) = takeDrop 20 s80 -> (s20_1, s40) = takeDrop 20 s60 -> (s20_2, s20_3) = takeDrop 20 s40 -> abcde1 = foldl (doit f1 0x5a827999) abcde0 s20_0 -> abcde2 = foldl (doit f2 0x6ed9eba1) abcde1 s20_1 -> abcde3 = foldl (doit f3 0x8f1bbcdc) abcde2 s20_2 -> abcde4 = foldl (doit f2 0xca62c1d6) abcde3 s20_3 -> f1 (x, y, z) = (x .&. y) .|. ((complement x) .&. z) -> f2 (x, y, z) = x `xor` y `xor` z -> f3 (x, y, z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) -> (a, b, c, d, e ) = abcde0 -> (a', b', c', d', e') = abcde4 -> abcde5 = (a + a', b + b', c + c', d + d', e + e') - -> doit :: (XYZ -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE -> doit f k (a, b, c, d, e) w = (a', a, rotL b 30, c, d) -> where a' = rotL a 5 + f(b, c, d) + e + w + k - -> sha1_add_ws :: Int -> ([Word32], [Word32], [Word32], [Word32]) -> [Word32] -> sha1_add_ws 80 _ = [] -> sha1_add_ws n (w1:w1s, w2:w2s, w3:w3s, w4:w4s) -> = w:sha1_add_ws (n + 1) (w1s ++ [w], w2s ++ [w], w3s ++ [w], w4s ++ [w]) -> where w = rotL (foldr1 xor [w1, w2, w3, w4]) 1 -> sha1_add_ws _ _ = error "Case not defined in sha1_add_ws" -> -> get_word_32s :: String -> [Word32] -> get_word_32s "" = [] -> get_word_32s ss = this:rest -> where (s, ss') = takeDrop 4 ss -> this = sum $ zipWith shiftL (map (fromIntegral.ord) s) [24, 16, 8, 0] -> rest = get_word_32s ss' - -> takeDrop :: Int -> [a] -> ([a], [a]) -> takeDrop _ [] = ([], []) -> takeDrop 0 xs = ([], xs) -> takeDrop n (x:xs) = (x:ys, zs) -> where (ys, zs) = takeDrop (n-1) xs - -> sha1_step_5_display :: ABCDE -> String -> sha1_step_5_display (a, b, c, d, e) -> = foldr (\x y -> display_32bits_as_hex x ++ y) "" [a, b, c, d, e] - -> sha1_step_5_concat :: ABCDE -> String -> sha1_step_5_concat (a, b, c, d, e) -> = foldr (\x y -> display_32bits_as_8bits x y) "" [a, b, c, d, e] - -> display_32bits_as_hex :: Word32 -> String -> display_32bits_as_hex x0 = map getc [y8,y7,y6,y5,y4,y3,y2,y1] -> where (x1, y1) = divMod x0 16 -> (x2, y2) = divMod x1 16 -> (x3, y3) = divMod x2 16 -> (x4, y4) = divMod x3 16 -> (x5, y5) = divMod x4 16 -> (x6, y6) = divMod x5 16 -> (y8, y7) = divMod x6 16 -> getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) - -> display_32bits_as_8bits :: Word32 -> ShowS -> display_32bits_as_8bits x0 l -> = getn 3 : getn 2 : getn 1 : getn 0 : l -> where getn n = chr (fromIntegral (x0 `shiftR` (n*8) .&. 0xFF)) - -> rotL :: Word32 -> Rotation -> Word32 -> rotL a s = shiftL a s .|. shiftL a (s-32) - diff --git a/src/HAppS/Crypto/W64.hs b/src/HAppS/Crypto/W64.hs deleted file mode 100644 --- a/src/HAppS/Crypto/W64.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE CPP, UndecidableInstances #-} -module HAppS.Crypto.W64 where - -import HAppS.Crypto.DES -import HAppS.Crypto.SHA1 -import Data.List -import Numeric(readHex) -#ifdef TEST -import Test.QuickCheck -#endif - ---the first character to be encrypted is 0 1 2 3 the number that should ---be ignored at the end of the string - - -pad :: String -> String -pad x = padding++x - where - padLength = 4 - (length x) `mod` 4 - padding = (toEnum padLength) : (take (padLength-1) $ repeat '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 - ---assume padded -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 x = map quadCharToW64 $ toQuadChars $ pad x - -w64sToString :: (Enum b) => [Integer] -> [b] -w64sToString x = unpad $ concat $ map w64ToQuadChar x - -prop_stringW64 :: String -> Bool -prop_stringW64 x = x == (w64sToString $ stringToW64s x) - ---des takes a 64 bit number and encrypts it with another 64 bit number - ---so string DES is an key string converted to a w64 and a value converted ---to a list of w64s ---the result is then converted from a list of w64s back to a string ---the key is an sha1 hash of the string converted to a 64 bit int or --- the first 16 hex digits -- `1/3 of total key space - -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) diff --git a/src/HAppS/Util/ByteStringCompat.hs b/src/HAppS/Util/ByteStringCompat.hs deleted file mode 100644 --- a/src/HAppS/Util/ByteStringCompat.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# OPTIONS -cpp #-} --- | Compatiblity for ByteStrings -module HAppS.Util.ByteStringCompat - (breakChar, breakCharEnd, - dropSpace, dropSpaceEnd, - rechunkLazy - ) where - -import Data.ByteString(ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L -import Data.Char(isSpace) -import Foreign - -#define STRICT2(f) f a b | a `seq` b `seq` False = undefined - - -{-# INLINE breakChar #-} -breakChar :: Char -> ByteString -> (ByteString, ByteString) -breakChar ch = B.break ((==) x) where x = B.c2w ch - --- | 'breakCharEnd' behaves like breakChar, but from the end of the --- ByteString. --- --- > breakCharEnd ('b') (pack "aabbcc") == ("aab","cc") --- --- and the following are equivalent: --- --- > breakCharEnd 'c' "abcdef" --- > let (x,y) = break (=='c') (reverse "abcdef") --- > in (reverse (drop 1 y), reverse x) --- -{-# INLINE breakCharEnd #-} -breakCharEnd :: Char -> ByteString -> (ByteString, ByteString) -breakCharEnd c p = B.breakEnd ((==) x) p where x = B.c2w c - -{-# INLINE dropSpace #-} -dropSpace :: ByteString -> ByteString -dropSpace = C.dropWhile isSpace - -{-# INLINE dropSpaceEnd #-} -dropSpaceEnd :: ByteString -> ByteString -dropSpaceEnd (B.PS x s l) = B.inlinePerformIO $ withForeignPtr x $ \p -> do - i <- lastnonspace (p `plusPtr` s) (l-1) - return $! if i == (-1) then B.empty else B.PS x s (i+1) - -lastnonspace :: Ptr Word8 -> Int -> IO Int -STRICT2(lastnonspace) -lastnonspace ptr n - | n < 0 = return n - | otherwise = do w <- peekElemOff ptr n - if B.isSpaceWord8 w then lastnonspace ptr (n-1) else return n - --- | Chunk a lazy bytestring into reasonable chunks - is id from outside. --- This is useful to make bytestring chunks reasonable sized for e.g. --- compression. -rechunkLazy :: L.ByteString -> L.ByteString -rechunkLazy = L.fromChunks . norm . foldr w ([],[],0) . L.toChunks - where norm (acc, [], _) = acc - norm (acc, cur, _) = B.concat cur : acc - w chunk (acc,cur,len) = let bl = len + B.length chunk - in if bl > 0x100 then (B.concat (chunk : cur) : acc, [], 0) else (acc, chunk : cur, bl) - diff --git a/src/HAppS/Util/Common.hs b/src/HAppS/Util/Common.hs deleted file mode 100644 --- a/src/HAppS/Util/Common.hs +++ /dev/null @@ -1,173 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : HAppS.Util.Common --- Copyright : (c) HAppS.org, 2005 --- License : BSD3 --- --- --- Various helper routines. ------------------------------------------------------------------------------ -module HAppS.Util.Common where - -import System.Log.Logger -import Control.Concurrent -import Control.Monad -import qualified Data.ByteString.Char8 as P -import Data.Char -import Data.Int -import System.IO -import System.Exit -import System.IO.Error -import System.Process -import System.IO.Unsafe -import System.Time - -type Seconds = Int -type EpochSeconds = Int64 -epochSeconds :: CalendarTime -> EpochSeconds -epochSeconds ct = let TOD sec _ = toClockTime ct in fromIntegral sec -eSecsToCalTime :: EpochSeconds -> IO CalendarTime -eSecsToCalTime s = toCalendarTime (TOD (fromIntegral s) 0) -epochPico :: CalendarTime -> Integer -epochPico ct = fromIntegral (epochSeconds ct) * 1000 - -----reliable getline and putline - -logMC :: Priority -> String -> IO () -logMC = logM "HAppS.Util.Common" - --- | Put a line into a handle followed by "\r\n" and echo to stdout -hPutLine :: Handle -> String -> IO () -hPutLine handle line = - do - hPutStr handle $ line - hPutStr handle "\r\n" - hFlush handle - logMC DEBUG line - return () - --- | Get a line from the handle and echo to stdout -hGetLn :: Handle -> IO String -hGetLn handle = do - let hGetLn' = do - c <- hGetChar handle - case c of - '\n' -> do return [] - '\r' -> do c2 <- hGetChar handle - if c2 == '\n' then return [] else getRest c - _ -> do getRest c - getRest c = do fmap (c:) hGetLn' - line <- hGetLn' - logMC DEBUG line - return line - - -unBracket, ltrim, rtrim, trim :: String -> String -unBracket = tail.reverse.tail.reverse.trim - -ltrim = dropWhile isSpace - -rtrim = reverse.ltrim.reverse -trim=ltrim.rtrim - -splitList :: Eq a => a -> [a] -> [[a]] -splitList _ [] = [] -splitList sep list = first:splitList sep rest - where (first,rest)=split (==sep) list - -splitListBy :: (a -> Bool) -> [a] -> [[a]] -splitListBy _ [] = [] -splitListBy f list = first:splitListBy f rest - where (first,rest)=split f list - --- | Split is like break, but the matching element is dropped. -split :: (a -> Bool) -> [a] -> ([a], [a]) -split f s = (left,right) - where - (left,right')=break f s - right = if null right' then [] else tail right' - - --- | Read file with a default value if the file does not exist. -mbReadFile :: a -> (String -> a) -> FilePath -> IO a -mbReadFile noth just path = - (do text <- readFile path;return $ just text) - `catch` \err -> if isDoesNotExistError err then return noth else ioError err - -doSnd :: (a -> b) -> (c,a) -> (c,b) -doSnd f (x,y) = (x,f y) - -doFst :: (a -> b) -> (a,c) -> (b,c) -doFst f (x,y) = (f x,y) - - -mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] -mapFst f = map (\ (x,y)->(f x,y)) -mapSnd :: (a -> b) -> [(x,a)] -> [(x,b)] -mapSnd f = map (\ (x,y)->(x,f y)) - -revmap :: a -> [a -> b] -> [b] -revmap item = map (\f->f item) - -comp :: Ord t => (a -> t) -> a -> a -> Ordering -comp f e1 e2 = f e1 `compare` f e2 - --- | Run an external command. Upon failure print status --- to stderr. -runCommand :: String -> [String] -> IO () -runCommand cmd args = do - (_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing - let pGetContents h = do mv <- newEmptyMVar - let put [] = putMVar mv [] - put xs = last xs `seq` putMVar mv xs - forkIO (hGetContents h >>= put) - takeMVar mv - os <- pGetContents outP - es <- pGetContents errP - ec <- waitForProcess pid - case ec of - ExitSuccess -> return () - ExitFailure e -> - do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")") - hPutStrLn stderr os - hPutStrLn stderr es - hPutStrLn stderr ("Raising error...") - fail "Running external command failed" - - --- | Unsafe tracing, outputs the message and the value to stderr. -debug :: Show a => String -> a -> a -debug msg s = - seq (unsafePerformIO (hPutStr stderr ("DEBUG: "++msg++"\n") >> - hPutStr stderr (show s++"\n"))) s - -{-# NOINLINE debugM #-} --- | Unsafe tracing messages inside a monad. -debugM :: Monad m => String -> m () -debugM msg = unsafePerformIO (P.hPutStr stderr (P.pack (msg++"\n")) >> hFlush stderr) `seq` return () - --- | Read in any monad. -readM :: (Monad m, Read t) => String -> m t -readM s = case readsPrec 0 s of - [(v,"")] -> return v - _ -> fail "readM: parse error" - --- | Convert Maybe into an another monad. -maybeM :: Monad m => Maybe a -> m a -maybeM (Just x) = return x -maybeM _ = fail "maybeM: Nothing" - --- ! Convert Bool into another monad -boolM :: (MonadPlus m) => Bool -> m Bool -boolM False = mzero -boolM True = return True - -notMb::a->Maybe a->Maybe a -notMb v1 v2 = maybe (Just v1) (const Nothing) $ v2 - -periodic :: [Int] -> IO () -> IO ThreadId -periodic ts x = forkIO $ periodic' ts x - -periodic' :: [Int] -> IO a -> IO a -periodic' [] x = x -periodic' (t:ts) x = x >> threadDelay (10^6*t) >> periodic' ts x diff --git a/src/HAppS/Util/Concurrent.hs b/src/HAppS/Util/Concurrent.hs deleted file mode 100644 --- a/src/HAppS/Util/Concurrent.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# OPTIONS -cpp #-} -{- Copyright (C) 2005 HAppS.org. All Rights Reserved. - - Using HAppS in GHCi - - Because there are many threads and reloading everything - is slow here is a way to kill all threads from GHCi: - add -DINTERACTIVE to the command line and use the - function happsKill from the prompt. --} -module HAppS.Util.Concurrent where - -import Control.Concurrent -import Prelude hiding (catch) -import Control.Exception -- hiding (catch) -#ifdef INTERACTIVE -import System.IO.Unsafe -import System.Mem -#endif - ---generic utils -forkEverSt :: (t -> IO t) -> t -> IO ThreadId -forkEverSt f state = fork (foreverSt f state) - -foreverSt :: (Monad m) => (t -> m t) -> t -> m b -foreverSt f state=do {newState<-f state;foreverSt f newState;} - -forkEver :: IO a -> IO ThreadId -forkEver a = fork (forever a) - -writeChanRight :: Chan (Either a b) -> b -> IO () -writeChanRight chan x= writeChan chan (Right x) - -writeChanLeft :: Chan (Either a b) -> a -> IO () -writeChanLeft chan x= writeChan chan (Left x) - -fork_ :: IO a -> IO () -fork_ c = fork c >> return () - --- | Fork a new thread. -fork :: IO a -> IO ThreadId - --- | Register an action to be run when ghci is restarted. -registerResetAction :: IO () -> IO () --- | Reset state -reset :: IO () - -forever :: IO a -> IO a - -#ifndef INTERACTIVE -forever a = do {finally a (forever a)} -fork c = forkIO (c >> return ()) -registerResetAction _ = return () -reset = return () -#else -forever a = try a >>= w - where w (Right _) = forever a - w (Left (AsyncException ThreadKilled)) = return () - w (Left e) = print e >> forever a -registerResetAction x = modifyMVar_ happsThreadList (return . (x:)) - -fork c = do - x <- forkIO (c >> return ()) - modifyMVar_ happsThreadList (\xs -> return (killThread x:xs)) - return x -reset = do xs <- swapMVar happsThreadList [] - sequence_ xs - threadDelay 10000 - performGC - logM "HAppS.Util.Concurrent" INFO "reset ok" -{-# NOINLINE happsThreadList #-} -happsThreadList = unsafePerformIO $ newMVar [] -#endif - --- | Sleep N seconds -sleep :: Int -> IO () -sleep n = threadDelay (n * second) where second = 1000000 diff --git a/src/HAppS/Util/Daemonize.hs b/src/HAppS/Util/Daemonize.hs deleted file mode 100644 --- a/src/HAppS/Util/Daemonize.hs +++ /dev/null @@ -1,61 +0,0 @@ -module HAppS.Util.Daemonize where - -import System.Directory -import System.Environment -import System.Exit -import System.Time -import Control.Concurrent -import Control.Exception.Extensible as E -import Control.Monad.Error -import HAppS.Crypto.SHA1 -import HAppS.Util.Common - - -{-- - 1. don't start the app if already running. the app is already running if something - has written to the daemon file recently - - 2. kill the app if the binary has changed since the app started ---} - --- Will placing the lock-file in the current directory work if we run the application from cron? -daemonize :: FilePath -> IO a -> IO a -daemonize binarylocation main = - do - startTime <- getClockTime - tid1 <- exitIfAlreadyRunning startTime - mId <- myThreadId - tid2 <- appCheck binarylocation startTime mId - main `finally` (mapM killThread [tid1,tid2]) - where - seconds n = noTimeDiff { tdSec = n } - exitIfAlreadyRunning startTime = - do - uniqueId <- getDaemonizedId - let name = ".haskell_daemon." ++ uniqueId - fe <- doesFileExist name - when fe $ - do - daemonTime <- getModificationTime name - when (diffClockTimes startTime daemonTime < seconds 2) $ - exitWith ExitSuccess >> return () - periodic (repeat 1) $ writeFile name "daemon" - - appCheck bl startTime mId = periodic (repeat 1) $ - do - fe <- doesFileExist bl - if not fe then return () else do - appModTime <- getModificationTime bl - if startTime < appModTime then - E.throwTo mId $ - ExitSuccess -- throws to the main thread - - else do - return () - -getDaemonizedId :: IO String -getDaemonizedId - = do prog <- getProgName - args <- getArgs - return (sha1 (prog ++ unwords args)) - diff --git a/src/HAppS/Util/TH.hs b/src/HAppS/Util/TH.hs deleted file mode 100644 --- a/src/HAppS/Util/TH.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module HAppS.Util.TH where - -import Language.Haskell.TH - -instanceD' :: CxtQ -> TypeQ -> Q [Dec] -> DecQ -instanceD' ctxt ty decs = - do decs' <- decs - let decs'' = filter (not . isSigD) decs' - instanceD ctxt ty (map return decs'') - -isSigD :: Dec -> Bool -isSigD (SigD _ _) = True -isSigD _ = False - diff --git a/src/HAppS/Util/Testing.hs b/src/HAppS/Util/Testing.hs deleted file mode 100644 --- a/src/HAppS/Util/Testing.hs +++ /dev/null @@ -1,52 +0,0 @@ -module HAppS.Util.Testing (qctest, qccheck, qcrun) where - -import Test.HUnit as HU -import Test.QuickCheck as QC -import Test.QuickCheck.Batch (TestResult(..),TestOptions(..),run) -import System.Random - -qctest :: QC.Testable a => a -> Test -qctest = qccheck defaultConfig - -qccheck :: QC.Testable a => Config -> a -> Test -qccheck config a = TestCase $ - do rnd <- newStdGen - tests config (evaluate a) rnd 0 0 [] - -qcrun :: QC.Testable a => a -> TestOptions -> Test -qcrun prop opts = TestCase $ - do res <- run prop opts - case res of - (TestOk _ _ _) -> return () - (TestExausted _ ntest _) -> - assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") - (TestFailed arguments ntest) -> - assertFailure $ ( "Falsifiable, after " - ++ show ntest - ++ " tests:\n" - ++ unlines arguments - ) - (TestAborted e) -> - assertFailure $ "Test failed with exception: " ++ show e - -tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Assertion -tests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = return () - | nfail == configMaxFail config = assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") - | otherwise = - do putStr (configEvery config ntest (arguments result)) - case ok result of - Nothing -> - tests config gen rnd1 ntest (nfail+1) stamps - Just True -> - tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - assertFailure $ ( "Falsifiable, after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 - diff --git a/src/HAppS/Util/TimeOut.hs b/src/HAppS/Util/TimeOut.hs deleted file mode 100644 --- a/src/HAppS/Util/TimeOut.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo #-} - ------------------------------------------------------------------------------ --- | --- Module : HAppS.Util.TimeOut --- Copyright : (c) HAppS.org, 2005 --- License : BSD3 --- --- Portability : uses mdo --- --- Timeout implementation for performing operations in the IO monad --- with a timeout added. Both using Maybe and exceptions to handle --- timeouts are supported. --- --- Timeouts can be implemented in GHC with either a global handler --- or a per-timeout thread which sleeps until the timeout. The latter --- is used in this module. Blocking on foreign calls can cause --- problems as GHC has no way of interrupting such threads. --- The module provides a slightly slower alternative implementation --- which returns even if the computation has blocked on a foreign --- call. This should not be an issue unless -threaded is used. --- --- The timeouts are currently limited to a maximum of about --- 2000 seconds. This is a feature of threadDelay, but --- supporting longer timeouts is certainly possible if --- that is desirable. --- --- For nested timeouts there are different ways to implement them: --- a) attach an id to the exception so that the catch knows wether it may catch --- this timout exception. I've choosen this because overhead is only passing --- and incrementing an integer value. A integer wrap araound is possible but --- too unlikely to happen to make me worry about it --- b) start a new workiing and killing thread so that if the original thread --- was run within withTimeOut itself it catches the exception and not an inner --- timout. (this is done in withSafeTimeOut, for another reason though) --- c) keep throwing exceptions until the the withTimeOut function kills the --- killing thread. But consider sequence (forever (timeOut threadDelay 10sec) ) --- In this case the exception will be called and the next timOut may be entered --- before the second Exception has been thrown --- --- All exceptions but the internal TimeOutExceptionI are rethrown in the calling thread ------------------------------------------------------------------------------ -module HAppS.Util.TimeOut - (withTimeOut, withTimeOutMaybe, - withSafeTimeOut, withSafeTimeOutMaybe, - TimeOutException(..), second - ) where - -import Control.Concurrent -import Control.Exception.Extensible as E -import Data.Typeable(Typeable) -import Data.IORef -import Data.Maybe -import System.IO.Unsafe (unsafePerformIO) - -import HAppS.Util.Concurrent - -type TimeOutTId = Int -- must be distinct within a thread only - -{-# NOINLINE timeOutIdState #-} -timeOutIdState :: IORef TimeOutTId -timeOutIdState = unsafePerformIO $ newIORef minBound - -nextTimeOutId :: IO TimeOutTId -nextTimeOutId = do - atomicModifyIORef timeOutIdState (\a -> let nid =nextId a in (nid,nid)) - where nextId i | i == maxBound = minBound - nextId i = i + 1 - -data TimeOutExceptionI = TimeOutExceptionI TimeOutTId -- internal exception, should only be used within this module - deriving(Typeable) - -data TimeOutException = TimeOutException -- that's the exception the user may catch - deriving(Typeable) - -instance Show TimeOutExceptionI where show _ = error "this TimeOutExceptionI should have been caught within this module" -instance E.Exception TimeOutExceptionI - -deriving instance Show TimeOutException -instance E.Exception TimeOutException - -throw' :: Exception exception => exception -> b -throw' = throw - -throwTo' :: Exception e => ThreadId -> e -> IO () -throwTo' = E.throwTo - -catch' :: Exception e => IO a -> (e -> IO a) -> IO a -catch' = E.catch - -try' :: IO a -> IO (Either SomeException a) -- give a type signature for try -try' = E.try - - --- module internal function -catchTimeOutI :: TimeOutTId -> IO a -> IO a -> IO a -catchTimeOutI toId op handler = - op `catch'` (\e@(TimeOutExceptionI i) -> if i == toId then handler else throw' e) - - --- | This is the normal timeout handler. It throws a TimeOutException exception, --- if the timeout occurs. - -withTimeOutMaybe :: Int -> IO a -> IO (Maybe a) -withTimeOutMaybe tout op = do - toId <- nextTimeOutId - wtid <- myThreadId - ktid <- fork ( do threadDelay tout - throwTo' wtid (TimeOutExceptionI toId) - ) - (catchTimeOutI toId) (fmap Just (op >>= \r -> killThread ktid >> return r)) (return Nothing) - -withTimeOut :: Int -> IO a -> IO a -withTimeOut tout op = maybeToEx =<< withTimeOutMaybe tout op - -maybeToEx :: (Monad m) => Maybe t -> m t -maybeToEx (Just r) = return r -maybeToEx Nothing = throw' TimeOutException - --- | Like timeOut, but additionally it works even if the computation is blocking --- async exceptions (explicitely or by a blocking FFI call). This consumes --- more resources than timeOut, but is still quite fast. -withSafeTimeOut :: Int -> IO a -> IO a -withSafeTimeOut tout op = maybeToEx =<< withSafeTimeOutMaybe tout op - --- | Like withTimeOutMaybe, but handles the operation blocking exceptions like withSafeTimeOut --- does. -withSafeTimeOutMaybe :: Int -> IO a -> IO (Maybe a) -withSafeTimeOutMaybe tout op = mdo - mv <- newEmptyMVar - wt <- fork $ do - t <- try' op - case t of - Left e -> tryPutMVar mv (Left e) - Right r -> tryPutMVar mv (Right (Just r)) - killThread kt - kt <- fork $ do - threadDelay tout - e <- tryPutMVar mv (Right Nothing) - if e then killThread wt else return () - eitherToEx =<< takeMVar mv - where eitherToEx (Left e) = throw' e - eitherToEx (Right r) = return r - - --- | Constant representing one second. -second :: Int -second = 1000000 diff --git a/src/Happstack/Crypto/Base64.hs b/src/Happstack/Crypto/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Crypto/Base64.hs @@ -0,0 +1,139 @@ +-- BSDLicensed +-- Copyright (c) 2002, Warrick Gray All rights reserved. +-- See http://www.ietf.org/rfc/rfc2045.txt for definition. +module Happstack.Crypto.Base64 ( + encode, + decode, + chop72 +) where + +{- + +The following properties should hold: + + decode . encode = id + decode . chop72 . encode = id + +I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, +the second variation corresponds better with the RFC above, but outside of +MIME applications might be undesireable. + + + +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. +-} + + + + +import Data.Array.Unboxed +import Data.Bits +import Data.Int +import Data.Char (chr,ord) + + +encodeArray :: UArray Int Char +encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') + , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') + , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') + , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') + , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') + , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') + , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') + , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') + , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') + , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] + + +-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) +-- clearly the upmost/leftmost 8 bits of the answer are 0. +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. +-- 0 represents a 4 :( +int4_char3 :: [Int] -> [Char] +int4_char3 (a:b:c:d:t) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) + in (chr (n `shiftR` 16 .&. 0xff)) + : (chr (n `shiftR` 8 .&. 0xff)) + : (chr (n .&. 0xff)) : int4_char3 t + +int4_char3 [a,b,c] = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) + in [ (chr (n `shiftR` 16 .&. 0xff)) + , (chr (n `shiftR` 8 .&. 0xff)) ] + +int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12) + in [ (chr (n `shiftR` 16 .&. 0xff)) ] + +int4_char3 [] = [] +int4_char3 _ = error "Case not implemented in int4_char3" + + + +-- Convert triplets of characters to +-- 4 base64 integers. The last entries +-- in the list may not produce 4 integers, +-- a trailing 2 character group gives 3 integers, +-- while a trailing single character gives 2 integers. +char3_int4 :: [Char] -> [Int] +char3_int4 (a:b:c:t) + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) + in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t + +char3_int4 [a,b] + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) + in [ (n `shiftR` 18 .&. 0x3f) + , (n `shiftR` 12 .&. 0x3f) + , (n `shiftR` 6 .&. 0x3f) ] + +char3_int4 [a] + = let n = (ord a `shiftL` 16) + in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] + +char3_int4 [] = [] + + +-- Retrieve base64 char, given an array index integer in the range [0..63] +enc1 :: Int -> Char +enc1 ch = encodeArray!ch + + +-- | Cut up a string into 72 char lines, each line terminated by CRLF. +chop72 :: String -> String +chop72 str = let (bgn,end) = splitAt 70 str + in if null end then bgn else bgn ++ "\r\n" ++ chop72 end + + +-- Pads a base64 code to a multiple of 4 characters, using the special +-- '=' character. +quadruplets :: String -> String +quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t +quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit +quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit +quadruplets [] = [] -- 24bit tail unit +quadruplets _ = error "Case not implemented in quadruplets" + +enc :: [Int] -> [Char] +enc = quadruplets . map enc1 + + +dcd :: String -> [Int] +dcd [] = [] +dcd (h:t) + | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t + | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t + | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t + | h == '+' = 62 : dcd t + | h == '/' = 63 : dcd t + | h == '=' = [] -- terminate data stream + | otherwise = dcd t + + +-- Principal encoding and decoding functions. +encode, decode :: String -> String +encode = enc . char3_int4 +decode = int4_char3 . dcd diff --git a/src/Happstack/Crypto/DES.lhs b/src/Happstack/Crypto/DES.lhs new file mode 100644 --- /dev/null +++ b/src/Happstack/Crypto/DES.lhs @@ -0,0 +1,287 @@ +> {-# LANGUAGE FlexibleInstances #-} +> {-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-} + + +{-- +Copyright (C) 2001 Ian Lynagh + +DES.lhs can be used under either the BSD or GPL. + +http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ + +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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. +--} + + +> module Happstack.Crypto.DES (des_enc, des_dec, Message, Enc) where + +> import Data.Bits +> import Data.Word + +more stuff just copied in + +> import Numeric + +-- added by alex + +> data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) + +> w64ToInteger :: Zord64 -> Integer +> w64ToInteger W64{lo=l,hi=h} = toInteger l + 0x100000000 * toInteger h +> integerToW64 :: Integer -> Zord64 +> integerToW64 x = case x `quotRem` 0x100000000 of +> (h,l) -> W64{lo=fromInteger l, hi=fromInteger h} + +> instance Show Zord64 where +> showsPrec _ = showInt . w64ToInteger + +> instance Read Zord64 where +> readsPrec _ s = [ (integerToW64 x,r) | (x,r) <- readDec s ] + +> instance Num Zord64 where +> W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} +> where lo' = lo_a + lo_b +> hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0 +> fromInteger = integerToW64 + +Added by alex + +> signum 0 = 0 +> signum _ = 1 +> x * y = integerToW64 $ (w64ToInteger x) * (w64ToInteger y) + + +> instance Bits Zord64 where +> W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} +> where lo' = lo_a .&. lo_b +> hi' = hi_a .&. hi_b +> W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} +> where lo' = lo_a .|. lo_b +> hi' = hi_a .|. hi_b +> shift w 0 = w +> shift W64{lo=l,hi=h} x +> | x > 63 = W64{lo=0,hi=0} +> | x > 31 = W64{lo = 0, hi = shift l (x-32)} +> | x > 0 = W64{lo = shift l x, hi = shift h x .|. shift l (x-32)} +> shift _ _ = error "Case not defined in Bits instance for Zord64" + +> instance Integral Zord64 where +> toInteger = w64ToInteger + +added by alex + +> quotRem numer divis = +> let (d,r)= quotRem (w64ToInteger numer) (w64ToInteger divis) +> in (fromInteger d,fromInteger r) + +> instance Real Zord64 +> instance Enum Zord64 + +--simplifying so we don't need all the hugs decls. + + +> type Rotation = Int +> type Key = Zord64 +> type Message = Zord64 +> type Enc = Zord64 + +> -- type BitsX = [Bool] +> type Bits4 = [Bool] +> type Bits6 = [Bool] +> type Bits32 = [Bool] +> type Bits48 = [Bool] +> type Bits56 = [Bool] +> type Bits64 = [Bool] + + + +> instance Num [Bool] where {} + + + +> instance Bits [Bool] where +> xor = zipWith (\x y -> (not x && y) || (x && not y)) +> rotate bits rot = drop rot' bits ++ take rot' bits +> where rot' = rot `mod` (length bits) + +> bitify :: Zord64 -> Bits64 +> bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] + +> unbitify :: Bits64 -> Zord64 + +Added by Alex + +> unbitify = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 + +> initial_permutation :: Bits64 -> Bits64 +> initial_permutation mb = map ((!!) mb) i +> where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, +> 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, +> 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, +> 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] + +> key_transformation :: Bits64 -> Bits56 +> key_transformation kb = map ((!!) kb) i +> where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, +> 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, +> 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, +> 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] + +> des_enc :: Message -> Key -> Enc +> des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] + +> des_dec :: Message -> Key -> Enc +> des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] + +> do_des :: [Rotation] -> Message -> Key -> Enc +> do_des rots m k = des_work rots (takeDrop 32 mb) kb +> where kb = key_transformation $ bitify k +> mb = initial_permutation $ bitify m + +> des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc +> des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) +> des_work (r:rs) mb kb = des_work rs mb' kb +> where mb' = do_round r mb kb + +> do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) +> do_round r (ml, mr) kb = (mr, m') +> where kb' = get_key kb r +> comp_kb = compression_permutation kb' +> expa_mr = expansion_permutation mr +> res = comp_kb `xor` expa_mr +> res' = tail $ iterate (trans 6) ([], res) +> trans n (_, b) = (take n b, drop n b) +> res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, +> s_box_3, s_box_4, +> s_box_5, s_box_6, +> s_box_7, s_box_8] res' +> res_p = p_box res_s +> m' = res_p `xor` ml + +> get_key :: Bits56 -> Rotation -> Bits56 +> get_key kb r = kb' +> where (kl, kr) = takeDrop 28 kb +> kb' = rotateL kl r ++ rotateL kr r + +> compression_permutation :: Bits56 -> Bits48 +> compression_permutation kb = map ((!!) kb) i +> where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, +> 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, +> 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, +> 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] + +> expansion_permutation :: Bits32 -> Bits48 +> expansion_permutation mb = map ((!!) mb) i +> where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, +> 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, +> 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, +> 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] + +> s_box :: [[Word8]] -> Bits6 -> Bits4 +> s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col +> where row = sum $ zipWith numericise [a,f] [1, 0] +> col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] +> numericise = (\x y -> if x then 2^y else 0) +> to_bool 0 _ = [] +> to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) +> s_box _ _ = error "second arg to s_box must have length 6" + +> s_box_1 :: Bits6 -> Bits4 +> s_box_1 = s_box i +> where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], +> [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], +> [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], +> [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] + +> s_box_2 :: Bits6 -> Bits4 +> s_box_2 = s_box i +> where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], +> [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], +> [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], +> [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] + +> s_box_3 :: Bits6 -> Bits4 +> s_box_3 = s_box i +> where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], +> [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], +> [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], +> [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] + +> s_box_4 :: Bits6 -> Bits4 +> s_box_4 = s_box i +> where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], +> [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], +> [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], +> [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] + +> s_box_5 :: Bits6 -> Bits4 +> s_box_5 = s_box i +> where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], +> [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], +> [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], +> [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] + +> s_box_6 :: Bits6 -> Bits4 +> s_box_6 = s_box i +> where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], +> [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], +> [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], +> [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] + +> s_box_7 :: Bits6 -> Bits4 +> s_box_7 = s_box i +> where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], +> [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], +> [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], +> [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] + +> s_box_8 :: Bits6 -> Bits4 +> s_box_8 = s_box i +> where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], +> [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], +> [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], +> [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] + +> p_box :: Bits32 -> Bits32 +> p_box kb = map ((!!) kb) i +> where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, +> 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] + +> final_perm :: Bits64 -> Bits64 +> final_perm kb = map ((!!) kb) i +> where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, +> 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, +> 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, +> 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] + +> takeDrop :: Int -> [a] -> ([a], [a]) +> takeDrop _ [] = ([], []) +> takeDrop 0 xs = ([], xs) +> takeDrop n (x:xs) = (x:ys, zs) +> where (ys, zs) = takeDrop (n-1) xs + diff --git a/src/Happstack/Crypto/HMAC.hs b/src/Happstack/Crypto/HMAC.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Crypto/HMAC.hs @@ -0,0 +1,18 @@ +module Happstack.Crypto.HMAC where + +import Happstack.Crypto.SHA1 +import Happstack.Crypto.Base64 + +import Data.Bits +import Data.Char + +hmacSHA1 :: String -> String -> String +hmacSHA1 key str + | length key > b = fail "hmacSHA1 doesn't support large keys yet" + | otherwise + = encode $ sha1Raw (doxor key opad ++ sha1Raw (doxor key ipad ++ str)) + where b = 64 + opad = replicate b '\x5C' + ipad = replicate b '\x36' + doxor a = zipWith fn (a++repeat '\0') + fn x y = chr (ord x `xor` ord y) diff --git a/src/Happstack/Crypto/MD5.hs b/src/Happstack/Crypto/MD5.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Crypto/MD5.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -funbox-strict-fields -fvia-c -optc-funroll-all-loops -optc-O3 #-} +-- +-- Module : Happstack.Crypto.MD5 +-- License : BSD3 +-- Maintainer : lemmih@vo.com +-- Author : Thomas.DuBuisson@mail.google.com +-- Stability : experimental +-- Portability : portable, requires bang patterns and ByteString +-- Tested with : GHC-6.8.1 +-- + +module Happstack.Crypto.MD5 + (md5 + ,md5InitialContext + ,md5Update + ,md5Finalize + ,MD5Context + ,md5File + ,stringMD5 + ,applyMD5Rounds + ,test + ) where + +import Prelude hiding ((!!)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal +import Data.Bits +import Data.List hiding ((!!)) +import Data.Int(Int64) +import Data.Word +import Foreign.Storable +import Foreign.Ptr +import Foreign.ForeignPtr +import Numeric +import System.Environment() +import System.IO + +blockSize :: Int +blockSize = 512 -- Block size in bits + +blockSizeBytes :: Int +blockSizeBytes = blockSize `div` 8 + +blockSizeBytesW64 :: Int64 +blockSizeBytesW64 = fromIntegral blockSizeBytes + +blockSizeBits :: Word64 +blockSizeBits = fromIntegral blockSize + +data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 +data MD5Context = MD5Ctx { mdPartial :: MD5Partial, + mdLeftOver :: ByteString, + mdTotalLen :: Word64 + } + +md5InitialContext :: MD5Context +md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 +h0, h1, h2, h3 :: Word32 +h0 = 0x67452301 +h1 = 0xEFCDAB89 +h2 = 0x98BADCFE +h3 = 0x10325476 + +-- | Will read the lazy ByteString and return the md5 digest. +-- Some application might want to wrap this function for type safty. +md5 :: L.ByteString -> L.ByteString +md5 bs = md5Finalize $ md5Update md5InitialContext bs + +md5Finalize :: MD5Context -> L.ByteString +md5Finalize !ctx@(MD5Ctx (MD5Par _ _ _ _) r !totLen) = + let totLen' = (totLen + 8*fromIntegral l) :: Word64 + padBS = B.pack $ 0x80 : replicate lenZeroPad 0 ++ size_split 8 totLen' + + (MD5Ctx (MD5Par a' b' c' d') _ _) = md5Update ctx (L.fromChunks [r,padBS]) + in L.pack $ concatMap (size_split 4) [a',b',c',d'] + where + l = B.length r + lenZeroPad = if (l+1) <= blockSizeBytes - 8 + then (blockSizeBytes - 8) - (l+1) + else (2*blockSizeBytes - 8) - (l+1) + +size_split :: (Integral t, Num a) => Int -> t -> [a] +size_split 0 _ = [] +size_split p n = (fromIntegral d):size_split (p-1) n' + where (n', d) = divMod n 256 + +md5Update :: MD5Context -> L.ByteString -> MD5Context +md5Update ctx bsLazy = + let _ = L.toChunks bsLazy + blks = block bsLazy + in foldl' performMD5Update ctx blks + +block :: L.ByteString -> [ByteString] +block bs = case L.toChunks bs of + [] -> [] + _ -> (B.concat . L.toChunks) top : block rest + where + (top,rest) = L.splitAt blockSizeBytesW64 bs +{-# INLINE block #-} + +-- Assumes ByteString length == blockSizeBytes, will fold the +-- context across calls to applyMD5Rounds. +performMD5Update :: MD5Context -> ByteString -> MD5Context +performMD5Update !ctx@(MD5Ctx !par@(MD5Par !a !b !c !d) _ !len) bs = + let MD5Par a' b' c' d' = applyMD5Rounds par bs + in if B.length bs == blockSizeBytes + then MD5Ctx { + mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), + mdLeftOver = B.empty, + mdTotalLen = len + blockSizeBits + } + else ctx { mdLeftOver = bs } + +applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial +applyMD5Rounds (MD5Par a b c d) w = + let -- Round 1 + !r0 = ff a b c d (w!!0) 7 3614090360 + !r1 = ff d r0 b c (w!!1) 12 3905402710 + !r2 = ff c r1 r0 b (w!!2) 17 606105819 + !r3 = ff b r2 r1 r0 (w!!3) 22 3250441966 + !r4 = ff r0 r3 r2 r1 (w!!4) 7 4118548399 + !r5 = ff r1 r4 r3 r2 (w!!5) 12 1200080426 + !r6 = ff r2 r5 r4 r3 (w!!6) 17 2821735955 + !r7 = ff r3 r6 r5 r4 (w!!7) 22 4249261313 + !r8 = ff r4 r7 r6 r5 (w!!8) 7 1770035416 + !r9 = ff r5 r8 r7 r6 (w!!9) 12 2336552879 + !r10 = ff r6 r9 r8 r7 (w!!10) 17 4294925233 + !r11 = ff r7 r10 r9 r8 (w!!11) 22 2304563134 + !r12 = ff r8 r11 r10 r9 (w!!12) 7 1804603682 + !r13 = ff r9 r12 r11 r10 (w!!13) 12 4254626195 + !r14 = ff r10 r13 r12 r11 (w!!14) 17 2792965006 + !r15 = ff r11 r14 r13 r12 (w!!15) 22 1236535329 + -- Round 2 + !r16 = gg r12 r15 r14 r13 (w!!1) 5 4129170786 + !r17 = gg r13 r16 r15 r14 (w!!6) 9 3225465664 + !r18 = gg r14 r17 r16 r15 (w!!11) 14 643717713 + !r19 = gg r15 r18 r17 r16 (w!!0) 20 3921069994 + !r20 = gg r16 r19 r18 r17 (w!!5) 5 3593408605 + !r21 = gg r17 r20 r19 r18 (w!!10) 9 38016083 + !r22 = gg r18 r21 r20 r19 (w!!15) 14 3634488961 + !r23 = gg r19 r22 r21 r20 (w!!4) 20 3889429448 + !r24 = gg r20 r23 r22 r21 (w!!9) 5 568446438 + !r25 = gg r21 r24 r23 r22 (w!!14) 9 3275163606 + !r26 = gg r22 r25 r24 r23 (w!!3) 14 4107603335 + !r27 = gg r23 r26 r25 r24 (w!!8) 20 1163531501 + !r28 = gg r24 r27 r26 r25 (w!!13) 5 2850285829 + !r29 = gg r25 r28 r27 r26 (w!!2) 9 4243563512 + !r30 = gg r26 r29 r28 r27 (w!!7) 14 1735328473 + !r31 = gg r27 r30 r29 r28 (w!!12) 20 2368359562 + -- Round 3 + !r32 = hh r28 r31 r30 r29 (w!!5) 4 4294588738 + !r33 = hh r29 r32 r31 r30 (w!!8) 11 2272392833 + !r34 = hh r30 r33 r32 r31 (w!!11) 16 1839030562 + !r35 = hh r31 r34 r33 r32 (w!!14) 23 4259657740 + !r36 = hh r32 r35 r34 r33 (w!!1) 4 2763975236 + !r37 = hh r33 r36 r35 r34 (w!!4) 11 1272893353 + !r38 = hh r34 r37 r36 r35 (w!!7) 16 4139469664 + !r39 = hh r35 r38 r37 r36 (w!!10) 23 3200236656 + !r40 = hh r36 r39 r38 r37 (w!!13) 4 681279174 + !r41 = hh r37 r40 r39 r38 (w!!0) 11 3936430074 + !r42 = hh r38 r41 r40 r39 (w!!3) 16 3572445317 + !r43 = hh r39 r42 r41 r40 (w!!6) 23 76029189 + !r44 = hh r40 r43 r42 r41 (w!!9) 4 3654602809 + !r45 = hh r41 r44 r43 r42 (w!!12) 11 3873151461 + !r46 = hh r42 r45 r44 r43 (w!!15) 16 530742520 + !r47 = hh r43 r46 r45 r44 (w!!2) 23 3299628645 + -- Round 4 + !r48 = ii r44 r47 r46 r45 (w!!0) 6 4096336452 + !r49 = ii r45 r48 r47 r46 (w!!7) 10 1126891415 + !r50 = ii r46 r49 r48 r47 (w!!14) 15 2878612391 + !r51 = ii r47 r50 r49 r48 (w!!5) 21 4237533241 + !r52 = ii r48 r51 r50 r49 (w!!12) 6 1700485571 + !r53 = ii r49 r52 r51 r50 (w!!3) 10 2399980690 + !r54 = ii r50 r53 r52 r51 (w!!10) 15 4293915773 + !r55 = ii r51 r54 r53 r52 (w!!1) 21 2240044497 + !r56 = ii r52 r55 r54 r53 (w!!8) 6 1873313359 + !r57 = ii r53 r56 r55 r54 (w!!15) 10 4264355552 + !r58 = ii r54 r57 r56 r55 (w!!6) 15 2734768916 + !r59 = ii r55 r58 r57 r56 (w!!13) 21 1309151649 + !r60 = ii r56 r59 r58 r57 (w!!4) 6 4149444226 + !r61 = ii r57 r60 r59 r58 (w!!11) 10 3174756917 + !r62 = ii r58 r61 r60 r59 (w!!2) 15 718787259 + !r63 = ii r59 r62 r61 r60 (w!!9) 21 3951481745 + in MD5Par r60 r63 r62 r61 + where + f !x !y !z = (x .&. y) .|. ((complement x) .&. z) + {-# INLINE f #-} + g !x !y !z = (x .&. z) .|. (y .&. (complement z)) + {-# INLINE g #-} + h !x !y !z = (x `xor` y `xor` z) + {-# INLINE h #-} + i !x !y !z = y `xor` (x .|. (complement z)) + {-# INLINE i #-} + ff a_ b_ c_ d_ x s ac = {-# SCC "ff" #-} + let !a' = f b_ c_ d_ + x + ac + a_ + !a'' = rotateL a' s + in a'' + b_ + {-# INLINE ff #-} + gg a_ b_ c_ d_ x s ac = {-# SCC "gg" #-} + let !a' = g b_ c_ d_ + x + ac + a_ + !a'' = rotateL a' s + in a'' + b_ + {-# INLINE gg #-} + hh a_ b_ c_ d_ x s ac = {-# SCC "hh" #-} + let !a' = h b_ c_ d_ + x + ac + a_ + !a'' = rotateL a' s + in a'' + b_ + {-# INLINE hh #-} + ii a_ b_ c_ d_ x s ac = {-# SCC "ii" #-} + let !a' = i b_ c_ d_ + x + ac + a_ + !a'' = rotateL a' s + in a'' + b_ + {-# INLINE ii #-} + (!!) word32s pos = getNthWord pos word32s + {-# INLINE (!!) #-} + + getNthWord n (PS ptr off _) = + inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do + let p = castPtr $ plusPtr ptr' off + peekElemOff p n + {-# INLINE getNthWord #-} +{-# INLINE applyMD5Rounds #-} + +stringMD5 :: L.ByteString -> String +stringMD5 lazy = + let x = L.toChunks lazy + w = B.unpack (B.concat x) + s = map (\v -> showHex v "") w + s' = map (\v -> if length v == 1 then '0':v else v) s + in concat s' + +test :: IO () +test = do + let h = md5 $ L.pack [] + putStrLn $ "Hash is: " ++ (stringMD5 h) + putStrLn $ "Should Be: d41d8cd98f00b204e9800998ecf8427e" + +md5File :: String -> IO () +md5File f = do + h <- openFile f ReadMode + s <- L.hGetContents h + let hash = md5 s + putStrLn (stringMD5 hash) + return () + diff --git a/src/Happstack/Crypto/SHA1.lhs b/src/Happstack/Crypto/SHA1.lhs new file mode 100644 --- /dev/null +++ b/src/Happstack/Crypto/SHA1.lhs @@ -0,0 +1,165 @@ +{-- +Copyright (C) 2001 Ian Lynagh + +SHA.lhs can be used under either the BSD or GPL. + +http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ + +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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. +--} + +> module Happstack.Crypto.SHA1 (sha1, sha1Raw, sha1_size) where + +> import Data.Char +> import Data.Bits +> import Data.Word + +> type ABCDE = (Word32, Word32, Word32, Word32, Word32) +> type XYZ = (Word32, Word32, Word32) +> type Rotation = Int + +> sha1 :: String -> String +> sha1 s = s5 +> where s1_2 = sha1_step_1_2_pad_length s +> abcde = sha1_step_3_init +> abcde' = sha1_step_4_main abcde s1_2 +> s5 = sha1_step_5_display abcde' + +> sha1Raw :: String -> String +> sha1Raw s = s5 +> where s1_2 = sha1_step_1_2_pad_length s +> abcde = sha1_step_3_init +> abcde' = sha1_step_4_main abcde s1_2 +> s5 = sha1_step_5_concat abcde' + +> sha1_size :: (Integral a) => a -> String -> String +> sha1_size l s = s5 +> where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64::Integer))) "" +> abcde = sha1_step_3_init +> abcde' = sha1_step_4_main abcde s1_2 +> s5 = sha1_step_5_display abcde' + +> sha1_step_1_2_pad_length :: String -> String +> sha1_step_1_2_pad_length = sha1_step_1_2_work 0 + +> sha1_step_1_2_work :: Integer -> String -> String +> sha1_step_1_2_work c64 "" = padding ++ len +> where padding = '\128':replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) '\000' +> len = map chr $ size_split 8 c64 +> sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work (((c64 + 8) `mod` (2^64))::Integer) cs + +> replicate' :: Word16 -> a -> [a] +> replicate' 0 _ = [] +> replicate' n x = x:replicate' (n-1) x + +> size_split :: Int -> Integer -> [Int] +> size_split 0 _ = [] +> size_split p n = size_split (p-1) n' ++ [fromIntegral d] +> where (n', d) = divMod n 256 + +> sha1_step_3_init :: ABCDE +> sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0) + +[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + +wm3 = [13,14,15] +wm8 = [8,9,10,11,12,13,14,15] +wm14 = [2,3,4,5,6,7,8,9,10,11,12,13,14,15] +wm16 = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + +> sha1_step_4_main :: ABCDE -> String -> ABCDE +> sha1_step_4_main abcde "" = {- abcde -} abcde +> sha1_step_4_main abcde0 s = sha1_step_4_main abcde5 s' +> where (s64, s') = takeDrop 64 s +> s16 = get_word_32s s64 +> s80 = s16 ++ sha1_add_ws 16 (drop 13 s16, drop 8 s16, drop 2 s16, s16) +> (s20_0, s60) = takeDrop 20 s80 +> (s20_1, s40) = takeDrop 20 s60 +> (s20_2, s20_3) = takeDrop 20 s40 +> abcde1 = foldl (doit f1 0x5a827999) abcde0 s20_0 +> abcde2 = foldl (doit f2 0x6ed9eba1) abcde1 s20_1 +> abcde3 = foldl (doit f3 0x8f1bbcdc) abcde2 s20_2 +> abcde4 = foldl (doit f2 0xca62c1d6) abcde3 s20_3 +> f1 (x, y, z) = (x .&. y) .|. ((complement x) .&. z) +> f2 (x, y, z) = x `xor` y `xor` z +> f3 (x, y, z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) +> (a, b, c, d, e ) = abcde0 +> (a', b', c', d', e') = abcde4 +> abcde5 = (a + a', b + b', c + c', d + d', e + e') + +> doit :: (XYZ -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE +> doit f k (a, b, c, d, e) w = (a', a, rotL b 30, c, d) +> where a' = rotL a 5 + f(b, c, d) + e + w + k + +> sha1_add_ws :: Int -> ([Word32], [Word32], [Word32], [Word32]) -> [Word32] +> sha1_add_ws 80 _ = [] +> sha1_add_ws n (w1:w1s, w2:w2s, w3:w3s, w4:w4s) +> = w:sha1_add_ws (n + 1) (w1s ++ [w], w2s ++ [w], w3s ++ [w], w4s ++ [w]) +> where w = rotL (foldr1 xor [w1, w2, w3, w4]) 1 +> sha1_add_ws _ _ = error "Case not defined in sha1_add_ws" +> +> get_word_32s :: String -> [Word32] +> get_word_32s "" = [] +> get_word_32s ss = this:rest +> where (s, ss') = takeDrop 4 ss +> this = sum $ zipWith shiftL (map (fromIntegral.ord) s) [24, 16, 8, 0] +> rest = get_word_32s ss' + +> takeDrop :: Int -> [a] -> ([a], [a]) +> takeDrop _ [] = ([], []) +> takeDrop 0 xs = ([], xs) +> takeDrop n (x:xs) = (x:ys, zs) +> where (ys, zs) = takeDrop (n-1) xs + +> sha1_step_5_display :: ABCDE -> String +> sha1_step_5_display (a, b, c, d, e) +> = foldr (\x y -> display_32bits_as_hex x ++ y) "" [a, b, c, d, e] + +> sha1_step_5_concat :: ABCDE -> String +> sha1_step_5_concat (a, b, c, d, e) +> = foldr (\x y -> display_32bits_as_8bits x y) "" [a, b, c, d, e] + +> display_32bits_as_hex :: Word32 -> String +> display_32bits_as_hex x0 = map getc [y8,y7,y6,y5,y4,y3,y2,y1] +> where (x1, y1) = divMod x0 16 +> (x2, y2) = divMod x1 16 +> (x3, y3) = divMod x2 16 +> (x4, y4) = divMod x3 16 +> (x5, y5) = divMod x4 16 +> (x6, y6) = divMod x5 16 +> (y8, y7) = divMod x6 16 +> getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + +> display_32bits_as_8bits :: Word32 -> ShowS +> display_32bits_as_8bits x0 l +> = getn 3 : getn 2 : getn 1 : getn 0 : l +> where getn n = chr (fromIntegral (x0 `shiftR` (n*8) .&. 0xFF)) + +> rotL :: Word32 -> Rotation -> Word32 +> rotL a s = shiftL a s .|. shiftL a (s-32) + diff --git a/src/Happstack/Crypto/W64.hs b/src/Happstack/Crypto/W64.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Crypto/W64.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP, UndecidableInstances #-} +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 + +--the first character to be encrypted is 0 1 2 3 the number that should +--be ignored at the end of the string + + +pad :: String -> String +pad x = padding++x + where + padLength = 4 - (length x) `mod` 4 + padding = (toEnum padLength) : (replicate (padLength-1) '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 + +--assume padded +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) + +--des takes a 64 bit number and encrypts it with another 64 bit number + +--so string DES is an key string converted to a w64 and a value converted +--to a list of w64s +--the result is then converted from a list of w64s back to a string +--the key is an sha1 hash of the string converted to a 64 bit int or +-- the first 16 hex digits -- `1/3 of total key space + +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) diff --git a/src/Happstack/Util/ByteStringCompat.hs b/src/Happstack/Util/ByteStringCompat.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/ByteStringCompat.hs @@ -0,0 +1,68 @@ +{-# OPTIONS -cpp #-} +-- | Compatiblity for ByteStrings +module Happstack.Util.ByteStringCompat + (breakChar, breakCharEnd, + dropSpace, dropSpaceEnd, + rechunkLazy + ) where + +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Data.Char(isSpace) +import Foreign + +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined + + +-- | Semantically equivalent to break on strings +{-# INLINE breakChar #-} +breakChar :: Char -> ByteString -> (ByteString, ByteString) +breakChar ch = B.break ((==) x) where x = B.c2w ch + +-- | 'breakCharEnd' behaves like breakChar, but from the end of the +-- ByteString. +-- +-- > breakCharEnd ('b') (pack "aabbcc") == ("aab","cc") +-- +-- and the following are equivalent: +-- +-- > breakCharEnd 'c' "abcdef" +-- > let (x,y) = break (=='c') (reverse "abcdef") +-- > in (reverse (drop 1 y), reverse x) +-- +{-# INLINE breakCharEnd #-} +breakCharEnd :: Char -> ByteString -> (ByteString, ByteString) +breakCharEnd c p = B.breakEnd ((==) x) p where x = B.c2w c + +-- | Drops leading spaces in the ByteString +{-# INLINE dropSpace #-} +dropSpace :: ByteString -> ByteString +dropSpace = C.dropWhile isSpace + +-- | Drops trailing spaces in the ByteString +{-# INLINE dropSpaceEnd #-} +dropSpaceEnd :: ByteString -> ByteString +dropSpaceEnd (B.PS x s l) = B.inlinePerformIO $ withForeignPtr x $ \p -> do + i <- lastnonspace (p `plusPtr` s) (l-1) + return $! if i == (-1) then B.empty else B.PS x s (i+1) + +lastnonspace :: Ptr Word8 -> Int -> IO Int +STRICT2(lastnonspace) +lastnonspace ptr n + | n < 0 = return n + | otherwise = do w <- peekElemOff ptr n + if B.isSpaceWord8 w then lastnonspace ptr (n-1) else return n + +-- | Chunk a lazy bytestring into reasonable chunks - is id from outside. +-- This is useful to make bytestring chunks reasonable sized for e.g. +-- compression. +rechunkLazy :: L.ByteString -> L.ByteString +rechunkLazy = L.fromChunks . norm . foldr w ([],[],0) . L.toChunks + where norm (acc, [], _) = acc + norm (acc, cur, _) = B.concat cur : acc + w chunk (acc,cur,len) = let bl = len + B.length chunk + in if bl > 0x100 then (B.concat (chunk : cur) : acc, [], 0) else (acc, chunk : cur, bl) + diff --git a/src/Happstack/Util/Common.hs b/src/Happstack/Util/Common.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/Common.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Happstack.Util.Common +-- Copyright : (c) Happstack.com, 2009; (c) HAppS.org, 2005 +-- License : BSD3 +-- +-- +-- Various helper routines. +----------------------------------------------------------------------------- +module Happstack.Util.Common where + +import System.Log.Logger +import Control.Concurrent +import Control.Monad +import qualified Data.ByteString.Char8 as P +import Data.Char +import Data.Int +import System.IO +import System.Exit +import System.IO.Error +import System.Process +import System.IO.Unsafe +import System.Time + +type Seconds = Int +type EpochSeconds = Int64 +epochSeconds :: CalendarTime -> EpochSeconds +epochSeconds ct = let TOD sec _ = toClockTime ct in fromIntegral sec +eSecsToCalTime :: EpochSeconds -> IO CalendarTime +eSecsToCalTime s = toCalendarTime (TOD (fromIntegral s) 0) +epochPico :: CalendarTime -> Integer +epochPico ct = fromIntegral (epochSeconds ct) * 1000 + +----reliable getline and putline + +logMC :: Priority -> String -> IO () +logMC = logM "Happstack.Util.Common" + +-- | Put a line into a handle followed by "\r\n" and echo to stdout +hPutLine :: Handle -> String -> IO () +hPutLine handle line = + do + hPutStr handle $ line + hPutStr handle "\r\n" + hFlush handle + logMC DEBUG line + return () + +-- | Get a line from the handle and echo to stdout +hGetLn :: Handle -> IO String +hGetLn handle = do + let hGetLn' = do + c <- hGetChar handle + case c of + '\n' -> return [] + '\r' -> do c2 <- hGetChar handle + if c2 == '\n' then return [] else getRest c + _ -> getRest c + getRest c = fmap (c:) hGetLn' + line <- hGetLn' + logMC DEBUG line + return line + + +unBracket, ltrim, rtrim, trim :: String -> String +unBracket = tail . init . trim + +ltrim = dropWhile isSpace + +rtrim = reverse.ltrim.reverse +trim=ltrim.rtrim + +splitList :: Eq a => a -> [a] -> [[a]] +splitList _ [] = [] +splitList sep list = first:splitList sep rest + where (first,rest)=split (==sep) list + +splitListBy :: (a -> Bool) -> [a] -> [[a]] +splitListBy _ [] = [] +splitListBy f list = first:splitListBy f rest + where (first,rest)=split f list + +-- | Split is like break, but the matching element is dropped. +split :: (a -> Bool) -> [a] -> ([a], [a]) +split f s = (left,right) + where + (left,right')=break f s + right = if null right' then [] else tail right' + + +-- | Read file with a default value if the file does not exist. +mbReadFile :: a -> (String -> a) -> FilePath -> IO a +mbReadFile noth just path = + (do text <- readFile path;return $ just text) + `catch` \err -> if isDoesNotExistError err then return noth else ioError err + +doSnd :: (a -> b) -> (c,a) -> (c,b) +doSnd f (x,y) = (x,f y) + +doFst :: (a -> b) -> (a,c) -> (b,c) +doFst f (x,y) = (f x,y) + + +mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] +mapFst f = map (\ (x,y)->(f x,y)) +mapSnd :: (a -> b) -> [(x,a)] -> [(x,b)] +mapSnd f = map (\ (x,y)->(x,f y)) + +revmap :: a -> [a -> b] -> [b] +revmap item = map (\f->f item) + +comp :: Ord t => (a -> t) -> a -> a -> Ordering +comp f e1 e2 = f e1 `compare` f e2 + +-- | Run an external command. Upon failure print status +-- to stderr. +runCommand :: String -> [String] -> IO () +runCommand cmd args = do + (_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing + let pGetContents h = do mv <- newEmptyMVar + let put [] = putMVar mv [] + put xs = last xs `seq` putMVar mv xs + forkIO (hGetContents h >>= put) + takeMVar mv + os <- pGetContents outP + es <- pGetContents errP + ec <- waitForProcess pid + case ec of + ExitSuccess -> return () + ExitFailure e -> + do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")") + hPutStrLn stderr os + hPutStrLn stderr es + hPutStrLn stderr ("Raising error...") + fail "Running external command failed" + + +-- | Unsafe tracing, outputs the message and the value to stderr. +debug :: Show a => String -> a -> a +debug msg s = + seq (unsafePerformIO (hPutStr stderr ("DEBUG: "++msg++"\n") >> + hPutStr stderr (show s++"\n"))) s + +{-# NOINLINE debugM #-} +-- | Unsafe tracing messages inside a monad. +debugM :: Monad m => String -> m () +debugM msg = unsafePerformIO (P.hPutStr stderr (P.pack (msg++"\n")) >> hFlush stderr) `seq` return () + +-- | Read in any monad. +readM :: (Monad m, Read t) => String -> m t +readM s = case readsPrec 0 s of + [(v,"")] -> return v + _ -> fail "readM: parse error" + +-- | Convert Maybe into an another monad. +maybeM :: Monad m => Maybe a -> m a +maybeM (Just x) = return x +maybeM _ = fail "maybeM: Nothing" + +-- ! Convert Bool into another monad +boolM :: (MonadPlus m) => Bool -> m Bool +boolM False = mzero +boolM True = return True + +notMb :: a-> Maybe a-> Maybe a +notMb v1 v2 = maybe (Just v1) (const Nothing) $ v2 + +periodic :: [Int] -> IO () -> IO ThreadId +periodic ts = forkIO . periodic' ts + +-- a little something to fix the types of ^ +infixr 8 .^ +(.^) :: Int->Int->Int +a .^ b = a ^ b +periodic' :: [Int] -> IO a -> IO a +periodic' [] x = x +periodic' (t:ts) x = x >> threadDelay ((10 .^ 6)*t) >> periodic' ts x diff --git a/src/Happstack/Util/Concurrent.hs b/src/Happstack/Util/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/Concurrent.hs @@ -0,0 +1,86 @@ +{-# OPTIONS -cpp #-} +{- Copyright (c) Happstack.com, 2009; (c) HAppS.org, 2005 + + Using Happstack in GHCi + + Because there are many threads and reloading everything + is slow here is a way to kill all threads from GHCi: + add -DINTERACTIVE to the command line and use the + function happsKill from the prompt. +-} +module Happstack.Util.Concurrent where + +import Control.Concurrent +import Prelude hiding (catch) +import Control.Exception -- hiding (catch) +#ifdef INTERACTIVE +import System.IO.Unsafe +import System.Mem +#endif + +--generic utils +-- | Equivalent to a composition of fork and foreverSt +forkEverSt :: (t -> IO t) -> t -> IO ThreadId +forkEverSt f = fork . foreverSt f + +-- | Similar to forever but with an explicit state parameter threaded through +-- the computation. +foreverSt :: (Monad m) => (t -> m t) -> t -> m b +foreverSt f state= f state >>= foreverSt f + +-- | Equivalent to a composition of fork and forever +forkEver :: IO a -> IO ThreadId +forkEver = fork . forever + +-- | Lifts the argument with Right before writing it into the chan +writeChanRight :: Chan (Either a b) -> b -> IO () +writeChanRight chan = writeChan chan . Right + +-- | Lifts the argument with Left before writing it into the chan +writeChanLeft :: Chan (Either a b) -> a -> IO () +writeChanLeft chan = writeChan chan . Left + +-- | Fork that throws away the ThreadId +fork_ :: IO a -> IO () +fork_ c = fork c >> return () + +-- | Fork a new thread. +fork :: IO a -> IO ThreadId + +-- | Register an action to be run when ghci is restarted. +registerResetAction :: IO () -> IO () +-- | Reset state +reset :: IO () + +-- | A version of forever that will gracefully catch IO exceptions and continue +-- executing the provided action. +forever :: IO a -> IO a + +#ifndef INTERACTIVE +forever a = finally a (forever a) +fork c = forkIO (c >> return ()) +registerResetAction _ = return () +reset = return () +#else +forever a = try a >>= w + where w (Right _) = forever a + w (Left (AsyncException ThreadKilled)) = return () + w (Left e) = print e >> forever a +registerResetAction x = modifyMVar_ happsThreadList (return . (x:)) + +fork c = do + x <- forkIO (c >> return ()) + modifyMVar_ happsThreadList (\xs -> return (killThread x:xs)) + return x +reset = do xs <- swapMVar happsThreadList [] + sequence_ xs + threadDelay 10000 + performGC + logM "Happstack.Util.Concurrent" INFO "reset ok" +{-# NOINLINE happsThreadList #-} +happsThreadList = unsafePerformIO $ newMVar [] +#endif + +-- | Sleep N seconds +sleep :: Int -> IO () +sleep n = threadDelay (n * second) where second = 1000000 diff --git a/src/Happstack/Util/Cron.hs b/src/Happstack/Util/Cron.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/Cron.hs @@ -0,0 +1,15 @@ +module Happstack.Util.Cron (cron) where + +import Control.Concurrent (threadDelay) + +type Seconds = Int + +-- | Given an action f and a number of seconds t, cron will execute +-- f every t seconds with the first execution t seconds after cron is called. +-- cron does not spawn a new thread. +cron :: Seconds -> IO () -> IO a +cron seconds action + = loop + where loop = do threadDelay (10^(6 :: Int) * seconds) + action + loop diff --git a/src/Happstack/Util/Daemonize.hs b/src/Happstack/Util/Daemonize.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/Daemonize.hs @@ -0,0 +1,60 @@ +module Happstack.Util.Daemonize where + +import System.Directory +import System.Environment +import System.Exit +import System.Time +import Control.Concurrent +import Control.Exception.Extensible as E +import Control.Monad.Error +import Happstack.Crypto.SHA1 +import Happstack.Util.Common + + +{-- + 1. don't start the app if already running. the app is already running if something + has written to the daemon file recently + + 2. kill the app if the binary has changed since the app started +--} + +-- Will placing the lock-file in the current directory work if we run the application from cron? +daemonize :: FilePath -> IO a -> IO a +daemonize binarylocation main = + do + startTime <- getClockTime + tid1 <- exitIfAlreadyRunning startTime + mId <- myThreadId + tid2 <- appCheck binarylocation startTime mId + main `finally` (mapM killThread [tid1,tid2]) + where + seconds n = noTimeDiff { tdSec = n } + exitIfAlreadyRunning startTime = + do + uniqueId <- getDaemonizedId + let name = ".haskell_daemon." ++ uniqueId + fe <- doesFileExist name + when fe $ + do + daemonTime <- getModificationTime name + when (diffClockTimes startTime daemonTime < seconds 2) $ + exitWith ExitSuccess >> return () + periodic (repeat 1) $ writeFile name "daemon" + + appCheck bl startTime mId = periodic (repeat 1) $ + do + fe <- doesFileExist bl + if not fe then return () else do + appModTime <- getModificationTime bl + if startTime < appModTime then + E.throwTo mId $ + ExitSuccess -- throws to the main thread + + else return () + +getDaemonizedId :: IO String +getDaemonizedId + = do prog <- getProgName + args <- getArgs + return (sha1 (prog ++ unwords args)) + diff --git a/src/Happstack/Util/HostAddress.hs b/src/Happstack/Util/HostAddress.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/HostAddress.hs @@ -0,0 +1,32 @@ +-- Pure Haskell functions to convert HostAddress and HostAddress6 to a human +-- readable string format. +module Happstack.Util.HostAddress (showHostAddress, showHostAddress6, HostAddress, HostAddress6) where +import Data.Word (Word32) +import Numeric (showHex) +import Data.List (intersperse) + +type HostAddress = Word32 +type HostAddress6 = (Word32, Word32, Word32, Word32) + +-- | Converts a HostAddress to a String in dot-decimal notation +showHostAddress :: HostAddress -> String +showHostAddress num = concat [show q1, ".", show q2, ".", show q3, ".", show q4] + where (num',q1) = (num `quotRem` 256) + (num'',q2) = (num' `quotRem` 256) + (num''',q3) = (num'' `quotRem` 256) + (_,q4) = (num''' `quotRem` 256) + +-- | Converts a IPv6 HostAddress6 to standard hex notation +showHostAddress6 :: HostAddress6 -> String +showHostAddress6 (a,b,c,d) = + (concat . intersperse ":" . map (flip showHex $ "")) $ + [p1,p2,p3,p4,p5,p6,p7,p8] + where (a',p2) = (a `quotRem` 65536) + (_,p1) = (a' `quotRem` 65536) + (b',p4) = (b `quotRem` 65536) + (_,p3) = (b' `quotRem` 65536) + (c',p6) = (c `quotRem` 65536) + (_,p5) = (c' `quotRem` 65536) + (d',p8) = (d `quotRem` 65536) + (_,p7) = (d' `quotRem` 65536) + diff --git a/src/Happstack/Util/LogFormat.hs b/src/Happstack/Util/LogFormat.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/LogFormat.hs @@ -0,0 +1,57 @@ +module Happstack.Util.LogFormat + ( formatTimeCombined + , formatRequestCombined + ) where + +import System.Locale (defaultTimeLocale) +import Data.Time.Format (FormatTime(..), formatTime) + +-- Format the time as describe in the Apache combined log format. +-- http://httpd.apache.org/docs/2.2/logs.html#combined +-- +-- The format is: +-- [day/month/year:hour:minute:second zone] +-- day = 2*digit +-- month = 3*letter +-- year = 4*digit +-- hour = 2*digit +-- minute = 2*digit +-- second = 2*digit +-- zone = (`+' | `-') 4*digit +formatTimeCombined :: FormatTime t => t -> String +formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" + +-- Format the request as describe in the Apache combined log format. +-- http://httpd.apache.org/docs/2.2/logs.html#combined +-- +-- The format is: "%h - %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\"" +-- %h: This is the IP address of the client (remote host) which made the request to the server. +-- %u: This is the userid of the person requesting the document as determined by HTTP authentication. +-- %t: The time that the request was received. +-- %r: The request line from the client is given in double quotes. +-- %>s: This is the status code that the server sends back to the client. +-- %b: The last part indicates the size of the object returned to the client, not including the response headers. +-- %{Referer}: The "Referer" (sic) HTTP request header. +-- %{User-agent}: The User-Agent HTTP request header. +formatRequestCombined :: FormatTime t => + String + -> String + -> t + -> String + -> Int + -> Integer + -> String + -> String + -> String +formatRequestCombined host user time requestLine responseCode size referer userAgent = + unwords $ + [ host + , user + , "[" ++ formattedTime ++ "]" + , show requestLine + , show responseCode + , show size + , show referer + , show userAgent + ] + where formattedTime = formatTimeCombined time diff --git a/src/Happstack/Util/TH.hs b/src/Happstack/Util/TH.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/TH.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +module Happstack.Util.TH where + +import Language.Haskell.TH + +-- | Version of 'instanceD' that takes in a Q [Dec] instead of a [Q Dec] +-- and filters out signatures from the list of declarations +instanceD' :: CxtQ -> TypeQ -> Q [Dec] -> DecQ +instanceD' ctxt ty decs = + do decs' <- decs + let decs'' = filter (not . isSigD) decs' + instanceD ctxt ty (map return decs'') + +-- | Returns true if the Dec matches a SigD constructor +isSigD :: Dec -> Bool +isSigD (SigD _ _) = True +isSigD _ = False + diff --git a/src/Happstack/Util/Testing.hs b/src/Happstack/Util/Testing.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/Testing.hs @@ -0,0 +1,52 @@ +module Happstack.Util.Testing (qctest, qccheck, qcrun) where + +import Test.HUnit as HU +import Test.QuickCheck as QC +import Test.QuickCheck.Batch (TestResult(..),TestOptions(..),run) +import System.Random + +qctest :: QC.Testable a => a -> Test +qctest = qccheck defaultConfig + +qccheck :: QC.Testable a => Config -> a -> Test +qccheck config a = TestCase $ + do rnd <- newStdGen + tests config (evaluate a) rnd 0 0 [] + +qcrun :: QC.Testable a => a -> TestOptions -> Test +qcrun prop opts = TestCase $ + do res <- run prop opts + case res of + (TestOk _ _ _) -> return () + (TestExausted _ ntest _) -> + assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") + (TestFailed testArgs ntest) -> + assertFailure $ ( "Falsifiable, after " + ++ show ntest + ++ " tests:\n" + ++ unlines testArgs + ) + (TestAborted e) -> + assertFailure $ "Test failed with exception: " ++ show e + +tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Assertion +tests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = return () + | nfail == configMaxFail config = assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") + | otherwise = + do putStr (configEvery config ntest (arguments result)) + case ok result of + Nothing -> + tests config gen rnd1 ntest (nfail+1) stamps + Just True -> + tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + assertFailure $ ( "Falsifiable, after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + diff --git a/src/Happstack/Util/TimeOut.hs b/src/Happstack/Util/TimeOut.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/TimeOut.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Happstack.Util.TimeOut +-- Copyright : (c) Happstack.com, 2009; (c) HAppS.org, 2005 +-- License : BSD3 +-- +-- Portability : uses mdo +-- +-- Timeout implementation for performing operations in the IO monad +-- with a timeout added. Both using Maybe and exceptions to handle +-- timeouts are supported. +-- +-- Timeouts can be implemented in GHC with either a global handler +-- or a per-timeout thread which sleeps until the timeout. The latter +-- is used in this module. Blocking on foreign calls can cause +-- problems as GHC has no way of interrupting such threads. +-- The module provides a slightly slower alternative implementation +-- which returns even if the computation has blocked on a foreign +-- call. This should not be an issue unless -threaded is used. +-- +-- The timeouts are currently limited to a maximum of about +-- 2000 seconds. This is a feature of threadDelay, but +-- supporting longer timeouts is certainly possible if +-- that is desirable. +-- +-- For nested timeouts there are different ways to implement them: +-- a) attach an id to the exception so that the catch knows wether it may catch +-- this timout exception. I've choosen this because overhead is only passing +-- and incrementing an integer value. A integer wrap araound is possible but +-- too unlikely to happen to make me worry about it +-- b) start a new workiing and killing thread so that if the original thread +-- was run within withTimeOut itself it catches the exception and not an inner +-- timout. (this is done in withSafeTimeOut, for another reason though) +-- c) keep throwing exceptions until the the withTimeOut function kills the +-- killing thread. But consider sequence (forever (timeOut threadDelay 10sec) ) +-- In this case the exception will be called and the next timOut may be entered +-- before the second Exception has been thrown +-- +-- All exceptions but the internal TimeOutExceptionI are rethrown in the calling thread +----------------------------------------------------------------------------- +module Happstack.Util.TimeOut + (withTimeOut, withTimeOutMaybe, + withSafeTimeOut, withSafeTimeOutMaybe, + TimeOutException(..), second + ) where + +import Control.Concurrent +import Control.Exception.Extensible as E +import Data.Typeable(Typeable) +import Data.IORef +import Data.Maybe +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad (when) + +import Happstack.Util.Concurrent + +type TimeOutTId = Int -- must be distinct within a thread only + +{-# NOINLINE timeOutIdState #-} +timeOutIdState :: IORef TimeOutTId +timeOutIdState = unsafePerformIO $ newIORef minBound + +nextTimeOutId :: IO TimeOutTId +nextTimeOutId = + atomicModifyIORef timeOutIdState (\a -> let nid =nextId a in (nid,nid)) + where nextId i | i == maxBound = minBound + nextId i = i + 1 + +data TimeOutExceptionI = TimeOutExceptionI TimeOutTId -- internal exception, should only be used within this module + deriving(Typeable) + +data TimeOutException = TimeOutException -- that's the exception the user may catch + deriving(Typeable) + +instance Show TimeOutExceptionI where show _ = error "this TimeOutExceptionI should have been caught within this module" +instance E.Exception TimeOutExceptionI + +deriving instance Show TimeOutException +instance E.Exception TimeOutException + +throw' :: Exception exception => exception -> b +throw' = throw + +throwTo' :: Exception e => ThreadId -> e -> IO () +throwTo' = E.throwTo + +catch' :: Exception e => IO a -> (e -> IO a) -> IO a +catch' = E.catch + +try' :: IO a -> IO (Either SomeException a) -- give a type signature for try +try' = E.try + + +-- module internal function +catchTimeOutI :: TimeOutTId -> IO a -> IO a -> IO a +catchTimeOutI toId op handler = + op `catch'` (\e@(TimeOutExceptionI i) -> if i == toId then handler else throw' e) + +-- | This handler returns Nothing if the timeout occurs. +withTimeOutMaybe :: Int -> IO a -> IO (Maybe a) +withTimeOutMaybe tout op = do + toId <- nextTimeOutId + wtid <- myThreadId + ktid <- fork ( do threadDelay tout + throwTo' wtid (TimeOutExceptionI toId) + ) + (catchTimeOutI toId) (fmap Just (op >>= \r -> killThread ktid >> return r)) (return Nothing) + +-- | This is the normal timeout handler. It throws a TimeOutException exception, +-- if the timeout occurs. +withTimeOut :: Int -> IO a -> IO a +withTimeOut tout op = maybeToEx =<< withTimeOutMaybe tout op + +maybeToEx :: (Monad m) => Maybe t -> m t +maybeToEx (Just r) = return r +maybeToEx Nothing = throw' TimeOutException + +-- | Like timeOut, but additionally it works even if the computation is blocking +-- async exceptions (explicitely or by a blocking FFI call). This consumes +-- more resources than timeOut, but is still quite fast. +withSafeTimeOut :: Int -> IO a -> IO a +withSafeTimeOut tout op = maybeToEx =<< withSafeTimeOutMaybe tout op + +-- | Like withTimeOutMaybe, but handles the operation blocking exceptions like withSafeTimeOut +-- does. +withSafeTimeOutMaybe :: Int -> IO a -> IO (Maybe a) +withSafeTimeOutMaybe tout op = mdo + mv <- newEmptyMVar + wt <- fork $ do + t <- try' op + case t of + Left e -> tryPutMVar mv (Left e) + Right r -> tryPutMVar mv (Right (Just r)) + killThread kt + kt <- fork $ do + threadDelay tout + e <- tryPutMVar mv (Right Nothing) + when e $ killThread wt + eitherToEx =<< takeMVar mv + where eitherToEx (Left e) = throw' e + eitherToEx (Right r) = return r + + +-- | Constant representing one second. +second :: Int +second = 1000000 diff --git a/tests/HAppS/Util/Tests.hs b/tests/HAppS/Util/Tests.hs deleted file mode 100644 --- a/tests/HAppS/Util/Tests.hs +++ /dev/null @@ -1,28 +0,0 @@ --- |HUnit tests and QuickQuick properties for HAppS.Util.* -module HAppS.Util.Tests (allTests) where - -import HAppS.Util.Common (split) -import HAppS.Util.Testing (qctest) -import Test.HUnit as HU (Test(..),(~:)) - --- |All of the tests for happstack-util should be listed here. -allTests :: Test -allTests = - "happstack-util tests" ~: [ splitTest ] - --- |turn 'splitTest_prop' into an HUnit test with a label -splitTest :: Test -splitTest = "splitTest" ~: qctest splitTest_prop - --- |a QuickCheck property which tests 'split' -splitTest_prop :: Bool -> [Bool] -> Bool -splitTest_prop elem list = - let (left1, right1) = split (elem ==) list - (left2, right2) = break (elem ==) list - right2' = - case right2 of - (r:rs) | r == elem -> rs - _ -> right2 - in - (left1 == left2) && (right1 == right2') - diff --git a/tests/Happstack/Util/Tests.hs b/tests/Happstack/Util/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Util/Tests.hs @@ -0,0 +1,41 @@ +-- |HUnit tests and QuickQuick properties for Happstack.Util.* +module Happstack.Util.Tests (allTests) where + +import Happstack.Util.Common (split) +import Happstack.Util.Testing (qctest) +import Test.HUnit as HU (Test(..),(~:)) +import Happstack.Util.Tests.HostAddress + +-- |All of the tests for happstack-util should be listed here. +allTests :: Test +allTests = + "happstack-util tests" ~: + [splitTest + ,showHostAddressTest + ,showHostAddressTest + ] + +-- |turn 'splitTest_prop' into an HUnit test with a label +splitTest :: Test +splitTest = "splitTest" ~: qctest splitTest_prop + +-- |a QuickCheck property which tests 'split' +splitTest_prop :: Bool -> [Bool] -> Bool +splitTest_prop elem list = + let (left1, right1) = split (elem ==) list + (left2, right2) = break (elem ==) list + right2' = + case right2 of + (r:rs) | r == elem -> rs + _ -> right2 + in + (left1 == left2) && (right1 == right2') + +-- |test showHostAddress against inet_ntoa to ensure that the same results occur +showHostAddressTest :: Test +showHostAddressTest = "showHostAddressTest" ~: qctest propShowHostAddress + +-- |test showHostAddress6 against getNameInfo to ensure that the same results occur +showHostAddress6Test :: Test +showHostAddress6Test = "showHostAddress6Test" ~: qctest propShowHostAddress6 + diff --git a/tests/Happstack/Util/Tests/HostAddress.hs b/tests/Happstack/Util/Tests/HostAddress.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Util/Tests/HostAddress.hs @@ -0,0 +1,32 @@ +module Happstack.Util.Tests.HostAddress +(propShowHostAddress, propShowHostAddress6) +where + +import Happstack.Util.HostAddress +import System.IO.Unsafe +import Network.Socket (inet_ntoa, getNameInfo, NameInfoFlag(..), SockAddr(..), aNY_PORT) +import Data.Word (Word32) +import System.Random +import Test.QuickCheck + +instance Arbitrary Word32 where + arbitrary = choose (minBound, maxBound) + +instance Random Word32 where + randomR (a,b) g = (fromInteger i,g) + where (i,_) = randomR (toInteger a, toInteger b) g + random g = + randomR (minBound,maxBound) g + +propShowHostAddress :: HostAddress -> Bool +propShowHostAddress a = new == old + where old = (unsafePerformIO . inet_ntoa) a + new = showHostAddress a + +propShowHostAddress6 :: HostAddress6 -> Bool +propShowHostAddress6 a = new == old + where (Just old, _) = + (unsafePerformIO . getNameInfo [NI_NUMERICHOST] True False) $ + SockAddrInet6 aNY_PORT 0 a 0 + new = showHostAddress6 a + diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,6 +1,6 @@ module Main where -import HAppS.Util.Tests (allTests) +import Happstack.Util.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout)