happstack-util (empty) → 0.1
raw patch · 18 files changed
+1679/−0 lines, 18 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed
Dependencies added: HUnit, QuickCheck, array, base, bytestring, directory, extensible-exceptions, hslogger, mtl, old-time, process, random, template-haskell
Files
- COPYING +29/−0
- Setup.hs +3/−0
- happstack-util.cabal +64/−0
- src/HAppS/Crypto/Base64.hs +139/−0
- src/HAppS/Crypto/DES.lhs +287/−0
- src/HAppS/Crypto/HMAC.hs +18/−0
- src/HAppS/Crypto/MD5.hs +247/−0
- src/HAppS/Crypto/SHA1.lhs +165/−0
- src/HAppS/Crypto/W64.hs +89/−0
- src/HAppS/Util/ByteStringCompat.hs +65/−0
- src/HAppS/Util/Common.hs +173/−0
- src/HAppS/Util/Concurrent.hs +77/−0
- src/HAppS/Util/Daemonize.hs +61/−0
- src/HAppS/Util/TH.hs +15/−0
- src/HAppS/Util/Testing.hs +52/−0
- src/HAppS/Util/TimeOut.hs +148/−0
- tests/HAppS/Util/Tests.hs +28/−0
- tests/Test.hs +19/−0
+ COPYING view
@@ -0,0 +1,29 @@+Copyright (c) 2006, HAppS.org+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++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.++Neither the name of the HAppS.org; 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 COPYRIGHT HOLDERS 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 COPYRIGHT OWNER 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.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ happstack-util.cabal view
@@ -0,0 +1,64 @@+Cabal-version: >=1.2.3+Name: happstack-util+Version: 0.1+Synopsis: Web framework+License: BSD3+License-file: COPYING+Author: Happstack team, HAppS LLC+Maintainer: Happstack team <happs@googlegroups.com>+homepage: http://happstack.com+Category: Web, Distributed Computing+Description: Miscellaneous utilities for Happstack packages.+Build-type: Simple++Flag base4+ Description: Choose the even newer, even smaller, split-up base package.++Flag tests+ Description: Build the testsuite, and include the tests in the library+ Default: True++Library+ Build-Depends: mtl, hslogger >= 1.0.2, template-haskell, array,+ bytestring, old-time, process, directory, extensible-exceptions, + HUnit, QuickCheck, random+ if flag(base4)+ Build-Depends: base >= 4+ else+ Build-Depends: base < 4++ hs-source-dirs: src+ 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+ if flag(tests)+ Exposed-modules: HAppS.Util.Tests++ extensions: CPP, UndecidableInstances, BangPatterns, StandaloneDeriving,+ DeriveDataTypeable, TemplateHaskell, RecursiveDo+ ghc-options: -Wall+ GHC-Prof-Options: -auto-all++Executable happstack-util-tests+ Main-Is: Test.hs+ GHC-Options: -threaded+ Build-depends: HUnit+ hs-source-dirs: tests, src+ if flag(tests)+ Buildable: True+ else+ Buildable: False+
+ src/HAppS/Crypto/Base64.hs view
@@ -0,0 +1,139 @@+-- 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
+ src/HAppS/Crypto/DES.lhs view
@@ -0,0 +1,287 @@+> {-# 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+
+ src/HAppS/Crypto/HMAC.hs view
@@ -0,0 +1,18 @@+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)
+ src/HAppS/Crypto/MD5.hs view
@@ -0,0 +1,247 @@+{-# 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 ()+
+ src/HAppS/Crypto/SHA1.lhs view
@@ -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 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)+
+ src/HAppS/Crypto/W64.hs view
@@ -0,0 +1,89 @@+{-# 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)
+ src/HAppS/Util/ByteStringCompat.hs view
@@ -0,0 +1,65 @@+{-# 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)+
+ src/HAppS/Util/Common.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ src/HAppS/Util/Concurrent.hs view
@@ -0,0 +1,77 @@+{-# 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
+ src/HAppS/Util/Daemonize.hs view
@@ -0,0 +1,61 @@+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))+
+ src/HAppS/Util/TH.hs view
@@ -0,0 +1,15 @@+{-# 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+
+ src/HAppS/Util/Testing.hs view
@@ -0,0 +1,52 @@+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+
+ src/HAppS/Util/TimeOut.hs view
@@ -0,0 +1,148 @@+{-# 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
+ tests/HAppS/Util/Tests.hs view
@@ -0,0 +1,28 @@+-- |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')+
+ tests/Test.hs view
@@ -0,0 +1,19 @@+module Main where++import HAppS.Util.Tests (allTests)+import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT)+import System.Exit (exitFailure)+import System.IO (hIsTerminalDevice, stdout)++-- |A simple driver for running the local test suite.+main :: IO ()+main =+ do c <- do istty <- hIsTerminalDevice stdout+ if istty+ then runTestTT allTests+ else do (c,st) <- runTestText putTextToShowS allTests+ putStrLn (st "")+ return c+ case (failures c) + (errors c) of+ 0 -> return ()+ n -> exitFailure