happstack-util 0.1 → 0.2.1

raw patch · 34 files changed

+1767/−1584 lines, 34 filesdep +networkdep +old-localedep +parsecdep ~QuickCheckdep ~basedep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: network, old-locale, parsec, time

Dependency ranges changed: QuickCheck, base, random

API changes (from Hackage documentation)

Files

• happstack-util.cabal +35/−19
• src/HAppS/Crypto/Base64.hs +0/−139
• src/HAppS/Crypto/DES.lhs +0/−287
• src/HAppS/Crypto/HMAC.hs +0/−18
• src/HAppS/Crypto/MD5.hs +0/−247
• src/HAppS/Crypto/SHA1.lhs +0/−165
• src/HAppS/Crypto/W64.hs +0/−89
• src/HAppS/Util/ByteStringCompat.hs +0/−65
• src/HAppS/Util/Common.hs +0/−173
• src/HAppS/Util/Concurrent.hs +0/−77
• src/HAppS/Util/Daemonize.hs +0/−61
• src/HAppS/Util/TH.hs +0/−15
• src/HAppS/Util/Testing.hs +0/−52
• src/HAppS/Util/TimeOut.hs +0/−148
• src/Happstack/Crypto/Base64.hs +139/−0
• src/Happstack/Crypto/DES.lhs +287/−0
• src/Happstack/Crypto/HMAC.hs +18/−0
• src/Happstack/Crypto/MD5.hs +247/−0
• src/Happstack/Crypto/SHA1.lhs +165/−0
• src/Happstack/Crypto/W64.hs +89/−0
• src/Happstack/Util/ByteStringCompat.hs +68/−0
• src/Happstack/Util/Common.hs +177/−0
• src/Happstack/Util/Concurrent.hs +86/−0
• src/Happstack/Util/Cron.hs +15/−0
• src/Happstack/Util/Daemonize.hs +60/−0
• src/Happstack/Util/HostAddress.hs +32/−0
• src/Happstack/Util/LogFormat.hs +57/−0
• src/Happstack/Util/TH.hs +18/−0
• src/Happstack/Util/Testing.hs +52/−0
• src/Happstack/Util/TimeOut.hs +148/−0
• tests/HAppS/Util/Tests.hs +0/−28
• tests/Happstack/Util/Tests.hs +41/−0
• tests/Happstack/Util/Tests/HostAddress.hs +32/−0
• tests/Test.hs +1/−1

@@ -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 

@@ -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

@@ -1,287 +0,0 @@-> {-# LANGUAGE FlexibleInstances  #-}-> {-# OPTIONS -fno-warn-missing-methods #-}---{---Copyright (C) 2001 Ian Lynagh <igloo@earth.li>--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]--<ADDED BY ALEX>--> instance Num [Bool] where {}--</ADDED>--> 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-

@@ -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)

@@ -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 ()-

@@ -1,165 +0,0 @@-{---Copyright (C) 2001 Ian Lynagh <igloo@earth.li>--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)-

@@ -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)

@@ -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)-

@@ -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

@@ -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

@@ -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))-

@@ -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-

@@ -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-

@@ -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

@@ -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

@@ -0,0 +1,287 @@+> {-# LANGUAGE FlexibleInstances  #-}+> {-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-}+++{--+Copyright (C) 2001 Ian Lynagh <igloo@earth.li>++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]++<ADDED BY ALEX>++> instance Num [Bool] where {}++</ADDED>++> 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+

@@ -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)

@@ -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 ()+

@@ -0,0 +1,165 @@+{--+Copyright (C) 2001 Ian Lynagh <igloo@earth.li>++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)+

@@ -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)

@@ -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)+

@@ -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

@@ -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

@@ -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

@@ -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))+

@@ -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)+

@@ -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

@@ -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+

@@ -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+

@@ -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

@@ -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')-

@@ -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+

@@ -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+

@@ -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)