HAppS-Util (empty) → 0.9.2
raw patch · 17 files changed
+1557/−0 lines, 17 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, directory, hslogger, mtl, old-time, process, template-haskell
Files
- COPYING +29/−0
- HAppS-Util.cabal +36/−0
- Setup.hs +3/−0
- src/HAppS/Crypto/Base64.hs +137/−0
- src/HAppS/Crypto/DES.lhs +289/−0
- src/HAppS/Crypto/HMAC.hs +20/−0
- src/HAppS/Crypto/MD5.hs +245/−0
- src/HAppS/Crypto/SHA1.lhs +164/−0
- src/HAppS/Crypto/W64.hs +71/−0
- src/HAppS/Util/ByteStringCompat.hs +64/−0
- src/HAppS/Util/Common.hs +222/−0
- src/HAppS/Util/Concurrent.hs +75/−0
- src/HAppS/Util/Daemonize.hs +68/−0
- src/HAppS/Util/EventHandler.hs +20/−0
- src/HAppS/Util/Exception.hs +9/−0
- src/HAppS/Util/TH.hs +15/−0
- src/HAppS/Util/TimeOut.hs +90/−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.
+ HAppS-Util.cabal view
@@ -0,0 +1,36 @@+Name: HAppS-Util+Version: 0.9.2+Synopsis: Web framework+License: BSD3+License-file: COPYING+Copyright: 2007 HAppS LLC+Author: HAppS LLC+Category: Web, Distributed Computing+Maintainer: AlexJacobson@HAppS.org+Build-Depends: base, mtl, hslogger >= 1.0.2, template-haskell, array,+ bytestring, old-time, process, directory+Build-type: Simple+hs-source-dirs: src+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.EventHandler,+ HAppS.Util.Exception+ HAppS.Util.TimeOut + HAppS.Util.TH+extensions: CPP, ForeignFunctionInterface,+ OverlappingInstances, UndecidableInstances,+ RecursiveDo,+ RankNTypes, FlexibleInstances,+ TypeSynonymInstances+cpp-options: -DHADDOCK -DUNIX+ghc-options: -W -fno-warn-incomplete-patterns+GHC-Prof-Options: -auto-all
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ src/HAppS/Crypto/Base64.hs view
@@ -0,0 +1,137 @@+-- 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 [] = [] +++++-- 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 (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+++enc :: [Int] -> [Char]+enc = quadruplets . map enc1+++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,289 @@+> {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -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) where++> import Data.Bits+> import Data.Word+++-- > import ZordHUGS++ type Zord64 = Word64 ++more stuff just copied in++> import Numeric++-- added by alex++> data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded)++> w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi+> 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=lo,hi=hi} x+> | x > 63 = W64{lo=0,hi=0}+> | x > 31 = W64{lo = 0, hi = shift lo (x-32)}+> | x > 0 = W64{lo = shift lo x, hi = shift hi x .|. shift lo (x-32)}++> 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]++</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 = foldlStrict (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs++> 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_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,20 @@+module HAppS.Crypto.HMAC where++import HAppS.Crypto.SHA1+import HAppS.Crypto.Base64++-- import qualified Data.ByteString.Char8 as BS++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 b = zipWith fn (a++repeat '\0') b+ fn a b = chr (ord a `xor` ord b)
+ src/HAppS/Crypto/MD5.hs view
@@ -0,0 +1,245 @@+{-# OPTIONS_GHC -fbang-patterns -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 qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Internal+import Data.Bits+import Data.List+import Data.Int()+import Data.Word+import Foreign.Storable+import Foreign.Ptr+import Foreign.ForeignPtr+import Numeric+import System.Environment()+import System.IO++blockSize = 512 -- Block size in bits+blockSizeBytes = blockSize `div` 8+blockSizeBytesW64 = fromIntegral blockSizeBytes+blockSizeBits = (fromIntegral blockSize) :: Word64++data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32+data MD5Context = MD5Ctx { mdPartial :: MD5Partial,+ mdLeftOver :: ByteString,+ mdTotalLen :: Word64+ }++md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0+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+#ifdef HADDOCK+md5Finalize !ctx@(MD5Ctx (MD5Par _ _ _ _) rem !totLen) =+ let totLen' = (totLen + 8*fromIntegral l) :: Word64+ padBS = B.pack $ 0x80 : replicate lenZeroPad 0 ++ size_split 8 totLen'+{-+L.toChunks $ runPut ( do+ putWord8 0x80+ mapM_ putWord8 (replicate lenZeroPad 0)+ putWord64le totLen' )+-}+ (MD5Ctx (MD5Par a' b' c' d') _ _) = md5Update ctx (L.fromChunks [rem,padBS])+ in L.pack $ concatMap (size_split 4) [a',b',c',d']+ where+ l = B.length rem+ lenZeroPad = if (l+1) <= blockSizeBytes - 8+ then (blockSizeBytes - 8) - (l+1)+ else (2*blockSizeBytes - 8) - (l+1)++#endif+-- size_split :: Int -> a -> [Word8]+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+ [] -> []+ otherwise -> (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+#ifdef HADDOCK+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 } ++#endif+applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial+#ifdef HADDOCK+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 bs = runGet (skip (n*4) >> getWord32le) (L.fromChunks [bs])+ getNthWord n (PS ptr off _) =+ inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do+ let p = castPtr $ plusPtr ptr' off+ peekElemOff p n+ {-# INLINE getNthWord #-}+{-# INLINE applyMD5Rounds #-}+#endif+stringMD5 lazy = + let x = L.toChunks lazy+ w = B.unpack (B.concat x)+ s = map (\x -> showHex x "") w+ s' = map (\x -> if length x == 1 then '0':x else x) 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,164 @@+{--+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++> 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,71 @@+{-# OPTIONS -cpp -fglasgow-exts -fallow-undecidable-instances #-}+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 x = padding++x+ where + padLength = 4 - (length x) `mod` 4+ padding = (toEnum padLength) : (take (padLength-1) $ repeat 'A')++unpad x = drop (fromEnum $ head x) x++prop_PadUnPad x = x==(unpad $ pad x)++is4Char x = length x==4+quadCharToW64 x = fromInteger $ impl $ map (fromIntegral.fromEnum) x+ where impl [a,b,c,d]=(a*2^24+b*2^16+c*2^8+d)++w64ToQuadChar w64 = + map (toEnum.fromIntegral) $! reverse $! take 4 $! v ++ (repeat 0)+ where v = w64ToQuadNum w64++w64ToQuadNum w64 = unfoldr (\x->if x==0 then Nothing else + Just (x `mod` 256,x `div` 256)) + w64+++#ifdef TEST+prop_quadCharW64 x = is4Char x ==> x == (w64ToQuadChar $ quadCharToW64 x)+#endif++--assume padded+toQuadChars [] = []+toQuadChars (a:b:c:d:rest) = [a,b,c,d]:toQuadChars rest++stringToW64s x = map quadCharToW64 $ toQuadChars $ pad x+w64sToString x = unpad $ concat $ map w64ToQuadChar x++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 x = fromInteger $ fst $ head $ readHex $ take 16 x+stringToKey x = hexToW64 $ sha1 x++des_encrypt key v = map (flip des_enc $ stringToKey key) $ stringToW64s v++des_decrypt key v = + w64sToString $ + map (toInteger . flip des_dec (stringToKey key)) + v++prop_DES key val = val == (des_decrypt key $ des_encrypt key val)+
+ src/HAppS/Util/ByteStringCompat.hs view
@@ -0,0 +1,64 @@+{-# 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 = 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,222 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- 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 = 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 [] = []+--ltrim (' ':t)= ltrim t+--ltrim ('\t':t)= ltrim t+--ltrim x = x+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'+ ++{-+startsWith list [] = True+startsWith [] _ = False+startsWith (l:ist) (p:at) = l==p && (startsWith ist at)+endsWith list pat = startsWith (reverse list) (reverse pat)++readFileSince path pos = + do+ h <- openFile path ReadMode+ hSetBinaryMode h True+ hSeek h AbsoluteSeek pos+ since <- hGetContents h+ return (since,h)+ +copyFileSince origPath pos destPath =+ do+ (after,origHandle) <- readFileSince origPath pos+ writeFile destPath after+ hClose origHandle+-}++-- | 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++{-+atomicWriteFile path string =+ do+ current <- getClockTime >>= toCalendarTime+ writeFile (temp current path) string+ renameFile (temp current path) path+ where+ temp current path = + path++(formatCalendarTime defaultTimeLocale form current)+ form=".%Y_%m_%d_%H_%M_%S.temp"++readEither s = case reads s of+ [] -> Left s+ (x,s'):_->Right x++ifFilesExist [] y = y >> return ()+ifFilesExist (f:fs) y = doesFileExist f >>= \x -> + if x then ifFilesExist fs y else return ()+-}++doSnd f (x,y) = (x,f y)+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++{-+-- Consider replacing with better implementation+-- in future.+hGetContentsStrict h = do+ b <- hIsEOF h+ if b then return [] + else do+ c <- hGetChar h+ r <- hGetContentsStrict h+ return (c:r)+-}++-- | 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 False = mzero+boolM True = return True++notMb::a->Maybe a->Maybe a+notMb v1 v2 = maybe (Just v1) (const Nothing) $ v2++periodic ts x = forkIO $ periodic' ts x+periodic' [] x = x+periodic' (t:ts) x = x >> threadDelay (10^6*t) >> periodic' ts x
+ src/HAppS/Util/Concurrent.hs view
@@ -0,0 +1,75 @@+{-# 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 f state = fork (foreverSt f state)+foreverSt f state=do {newState<-f state;foreverSt f newState;}+forkEver a = fork (forever a)++writeChanRight chan x= writeChan chan (Right x)+writeChanLeft chan x= writeChan chan (Left x)++ignoreFail ret op = op `catch` + (\err ->(error $ "\n\n\nFAILED"++(show err)) >> return ret)++++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 ()++#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+++--ignoreFail ret op = op `catch` (\err ->(error $ "\n\n\nFAILED"++(show err)))
+ src/HAppS/Util/Daemonize.hs view
@@ -0,0 +1,68 @@+module HAppS.Util.Daemonize where ++import System.Directory+import System.Environment+import System.Exit+import System.Time+import Control.Concurrent+import Control.Exception+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 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 + throwTo mId $ ExitException ExitSuccess -- throws to the main thread+-- raiseSignal softwareTermination -- can we eliminate posix dependency?+ else do+ return ()++{--+ appCheck Nothing _ = return ()+ appCheck (Just bl) start = do at <- try $ getModificationTime bl+ case at of+ Right appModTime | start < appModTime+ -> raiseSignal softwareTermination+ _ -> return ()+--}++--daemonize = daemonize' Nothing+getDaemonizedId+ = do prog <- getProgName+ args <- getArgs+ return (sha1 (prog ++ unwords args))+
+ src/HAppS/Util/EventHandler.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.Util.EventHandler where++--import HAppS.MACID++{-+-- | Create an event handler for the 'dispatch' type which must be unique+-- and is used as base for dispatch. The Proxy argument is used only to+-- select the correct instance and should be ignored.+--+-- EventHandler is used by HAppS.Agents.WithBlockingIO and HAppS.Agents.SessionKeeperEx.+class EventHandler dispatch st ev res | dispatch -> st ev res where+ eventHandler :: Proxy dispatch -> Ev st ev res++data DoNothing st ev++instance EventHandler (DoNothing st ev) st ev () where+ eventHandler _ = return ()++-}
+ src/HAppS/Util/Exception.hs view
@@ -0,0 +1,9 @@+module HAppS.Util.Exception where++import Control.Exception as E++catchSome = E.catchJust interestingExceptions++interestingExceptions x@(ArithException _) = Just x+interestingExceptions x@(ArrayException _) = Just x+interestingExceptions _ = Nothing
+ 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/TimeOut.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- 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.+-----------------------------------------------------------------------------+module HAppS.Util.TimeOut + (withTimeOut, withTimeOutMaybe,+ withSafeTimeOut, withSafeTimeOutMaybe,+ TimeOutException(..), second+ ) where++import Control.Concurrent+import Control.Exception as E+import Data.Dynamic(toDyn)+import Data.Typeable(Typeable)++import HAppS.Util.Concurrent++data TimeOutException = TimeOutException+ deriving(Typeable)++-- | This is the normal timeout handler. It throws a dynamic exception (TimeOutException),+-- if the timeout occurs.++withTimeOut :: Int -> IO a -> IO a+withTimeOut tout op = do + wtid <- myThreadId+ ktid <- fork (threadDelay tout >> throwDynTo wtid TimeOutException)+ op `finally` killThread ktid+++-- | This is the normal timeout handler. If the computation fails or the timeout+-- is reached it returns Nothing.+withTimeOutMaybe :: Int -> IO a -> IO (Maybe a)+withTimeOutMaybe tout op = worker `E.catch` (\_ -> return Nothing)+ where worker = do wtid <- myThreadId+ ktid <- fork (threadDelay tout >> killThread wtid)+ res <- op `finally` killThread ktid+ return $ Just res+++-- | 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 = mdo+ mv <- newEmptyMVar+ wt <- fork $ do try op >>= tryPutMVar mv >> killThread kt+ kt <- fork $ do threadDelay tout+ e <- tryPutMVar mv $ Left $ DynException $ toDyn TimeOutException+ if e then killThread wt else return ()+ either throw return =<< takeMVar mv++-- | 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 (op >>= putMVar mv . Just) `E.catch` (\_ -> tryPutMVar mv Nothing >> return ())+ killThread kt+ kt <- fork $ do threadDelay tout+ e <- tryPutMVar mv Nothing+ if e then killThread wt else return ()+ takeMVar mv++-- | Constant representing one second.+second :: Int+second = 1000000+