diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. diff --git a/HAppS-Util.cabal b/HAppS-Util.cabal new file mode 100644 --- /dev/null +++ b/HAppS-Util.cabal @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/src/HAppS/Crypto/Base64.hs b/src/HAppS/Crypto/Base64.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Crypto/Base64.hs @@ -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 diff --git a/src/HAppS/Crypto/DES.lhs b/src/HAppS/Crypto/DES.lhs new file mode 100644 --- /dev/null +++ b/src/HAppS/Crypto/DES.lhs @@ -0,0 +1,289 @@ +> {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fno-warn-missing-methods #-} + + +{-- +Copyright (C) 2001 Ian Lynagh + +DES.lhs can be used under either the BSD or GPL. + +http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ + +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. +--} + + +> module HAppS.Crypto.DES (des_enc, des_dec) 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] + + + +> instance Num [Bool] + + + +> 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 + diff --git a/src/HAppS/Crypto/HMAC.hs b/src/HAppS/Crypto/HMAC.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Crypto/HMAC.hs @@ -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) diff --git a/src/HAppS/Crypto/MD5.hs b/src/HAppS/Crypto/MD5.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Crypto/MD5.hs @@ -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 () + diff --git a/src/HAppS/Crypto/SHA1.lhs b/src/HAppS/Crypto/SHA1.lhs new file mode 100644 --- /dev/null +++ b/src/HAppS/Crypto/SHA1.lhs @@ -0,0 +1,164 @@ +{-- +Copyright (C) 2001 Ian Lynagh + +SHA.lhs can be used under either the BSD or GPL. + +http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ + +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. +--} + +> module HAppS.Crypto.SHA1 (sha1, sha1Raw, sha1_size) where + +> import Data.Char +> import Data.Bits +> import Data.Word + +> type ABCDE = (Word32, Word32, Word32, Word32, Word32) +> type XYZ = (Word32, Word32, Word32) +> type Rotation = Int + +> sha1 :: String -> String +> sha1 s = s5 +> where s1_2 = sha1_step_1_2_pad_length s +> abcde = sha1_step_3_init +> abcde' = sha1_step_4_main abcde s1_2 +> s5 = sha1_step_5_display abcde' + +> sha1Raw :: String -> String +> sha1Raw s = s5 +> where s1_2 = sha1_step_1_2_pad_length s +> abcde = sha1_step_3_init +> abcde' = sha1_step_4_main abcde s1_2 +> s5 = sha1_step_5_concat abcde' + +> sha1_size :: (Integral a) => a -> String -> String +> sha1_size l s = s5 +> where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64))) "" +> abcde = sha1_step_3_init +> abcde' = sha1_step_4_main abcde s1_2 +> s5 = sha1_step_5_display abcde' + +> sha1_step_1_2_pad_length :: String -> String +> sha1_step_1_2_pad_length s = sha1_step_1_2_work 0 s + +> sha1_step_1_2_work :: Integer -> String -> String +> sha1_step_1_2_work c64 "" = padding ++ len +> where padding = '\128':replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) '\000' +> len = map chr $ size_split 8 c64 +> sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work ((c64 + 8) `mod` (2^64)) cs + +> replicate' :: Word16 -> a -> [a] +> replicate' 0 _ = [] +> replicate' n x = x:replicate' (n-1) x + +> size_split :: Int -> Integer -> [Int] +> size_split 0 _ = [] +> size_split p n = size_split (p-1) n' ++ [fromIntegral d] +> where (n', d) = divMod n 256 + +> sha1_step_3_init :: ABCDE +> sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0) + +[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + +wm3 = [13,14,15] +wm8 = [8,9,10,11,12,13,14,15] +wm14 = [2,3,4,5,6,7,8,9,10,11,12,13,14,15] +wm16 = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + +> sha1_step_4_main :: ABCDE -> String -> ABCDE +> sha1_step_4_main abcde "" = {- abcde -} abcde +> sha1_step_4_main abcde0 s = sha1_step_4_main abcde5 s' +> where (s64, s') = takeDrop 64 s +> s16 = get_word_32s s64 +> s80 = s16 ++ sha1_add_ws 16 (drop 13 s16, drop 8 s16, drop 2 s16, s16) +> (s20_0, s60) = takeDrop 20 s80 +> (s20_1, s40) = takeDrop 20 s60 +> (s20_2, s20_3) = takeDrop 20 s40 +> abcde1 = foldl (doit f1 0x5a827999) abcde0 s20_0 +> abcde2 = foldl (doit f2 0x6ed9eba1) abcde1 s20_1 +> abcde3 = foldl (doit f3 0x8f1bbcdc) abcde2 s20_2 +> abcde4 = foldl (doit f2 0xca62c1d6) abcde3 s20_3 +> f1 (x, y, z) = (x .&. y) .|. ((complement x) .&. z) +> f2 (x, y, z) = x `xor` y `xor` z +> f3 (x, y, z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) +> (a, b, c, d, e ) = abcde0 +> (a', b', c', d', e') = abcde4 +> abcde5 = (a + a', b + b', c + c', d + d', e + e') + +> doit :: (XYZ -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE +> doit f k (a, b, c, d, e) w = (a', a, rotL b 30, c, d) +> where a' = rotL a 5 + f(b, c, d) + e + w + k + +> sha1_add_ws :: Int -> ([Word32], [Word32], [Word32], [Word32]) -> [Word32] +> sha1_add_ws 80 _ = [] +> sha1_add_ws n (w1:w1s, w2:w2s, w3:w3s, w4:w4s) +> = w:sha1_add_ws (n + 1) (w1s ++ [w], w2s ++ [w], w3s ++ [w], w4s ++ [w]) +> where w = rotL (foldr1 xor [w1, w2, w3, w4]) 1 + +> get_word_32s :: String -> [Word32] +> get_word_32s "" = [] +> get_word_32s ss = this:rest +> where (s, ss') = takeDrop 4 ss +> this = sum $ zipWith shiftL (map (fromIntegral.ord) s) [24, 16, 8, 0] +> rest = get_word_32s ss' + +> takeDrop :: Int -> [a] -> ([a], [a]) +> takeDrop _ [] = ([], []) +> takeDrop 0 xs = ([], xs) +> takeDrop n (x:xs) = (x:ys, zs) +> where (ys, zs) = takeDrop (n-1) xs + +> sha1_step_5_display :: ABCDE -> String +> sha1_step_5_display (a, b, c, d, e) +> = foldr (\x y -> display_32bits_as_hex x ++ y) "" [a, b, c, d, e] + +> sha1_step_5_concat :: ABCDE -> String +> sha1_step_5_concat (a, b, c, d, e) +> = foldr (\x y -> display_32bits_as_8bits x y) "" [a, b, c, d, e] + +> display_32bits_as_hex :: Word32 -> String +> display_32bits_as_hex x0 = map getc [y8,y7,y6,y5,y4,y3,y2,y1] +> where (x1, y1) = divMod x0 16 +> (x2, y2) = divMod x1 16 +> (x3, y3) = divMod x2 16 +> (x4, y4) = divMod x3 16 +> (x5, y5) = divMod x4 16 +> (x6, y6) = divMod x5 16 +> (y8, y7) = divMod x6 16 +> getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + +> display_32bits_as_8bits :: Word32 -> ShowS +> display_32bits_as_8bits x0 l +> = getn 3 : getn 2 : getn 1 : getn 0 : l +> where getn n = chr (fromIntegral (x0 `shiftR` (n*8) .&. 0xFF)) + +> rotL :: Word32 -> Rotation -> Word32 +> rotL a s = shiftL a s .|. shiftL a (s-32) + diff --git a/src/HAppS/Crypto/W64.hs b/src/HAppS/Crypto/W64.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Crypto/W64.hs @@ -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) + diff --git a/src/HAppS/Util/ByteStringCompat.hs b/src/HAppS/Util/ByteStringCompat.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/ByteStringCompat.hs @@ -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) + diff --git a/src/HAppS/Util/Common.hs b/src/HAppS/Util/Common.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/Common.hs @@ -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 diff --git a/src/HAppS/Util/Concurrent.hs b/src/HAppS/Util/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/Concurrent.hs @@ -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))) diff --git a/src/HAppS/Util/Daemonize.hs b/src/HAppS/Util/Daemonize.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/Daemonize.hs @@ -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)) + diff --git a/src/HAppS/Util/EventHandler.hs b/src/HAppS/Util/EventHandler.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/EventHandler.hs @@ -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 () + +-} diff --git a/src/HAppS/Util/Exception.hs b/src/HAppS/Util/Exception.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/Exception.hs @@ -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 diff --git a/src/HAppS/Util/TH.hs b/src/HAppS/Util/TH.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/TH.hs @@ -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 + diff --git a/src/HAppS/Util/TimeOut.hs b/src/HAppS/Util/TimeOut.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Util/TimeOut.hs @@ -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 +