happstack-util-6.0.0/0000755000000000000000000000000011527320401012627 5ustar0000000000000000happstack-util-6.0.0/Setup.hs0000644000000000000000000000014111527320401014257 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks simpleUserHooks happstack-util-6.0.0/happstack-util.cabal0000644000000000000000000000622311527320401016547 0ustar0000000000000000Name: happstack-util Version: 6.0.0 Synopsis: Web framework License: BSD3 License-file: COPYING Author: Happstack team, HAppS LLC Maintainer: Happstack team homepage: http://happstack.com Category: Web, Distributed Computing Description: Miscellaneous utilities for Happstack packages. Build-type: Simple Cabal-version: >=1.6 source-repository head type: darcs subdir: happstack-util location: http://patch-tag.com/r/mae/happstack Flag base4 Description: Choose the even newer, even smaller, split-up base package. Flag tests Description: Build the testsuite, and include the tests in the library Default: False Library Build-Depends: array, bytestring, directory, extensible-exceptions, hslogger >= 1.0.2, mtl >= 1.1 && < 2.1, old-locale, old-time, parsec < 4, process, time, random, network >= 2.2 && < 3, template-haskell, unix-compat, filepath if flag(base4) Build-Depends: base >= 4 && < 5 else Build-Depends: base < 4 if !os(windows) build-depends: unix hs-source-dirs: src if flag(tests) hs-source-dirs: tests Exposed-modules: Happstack.Crypto.Base64, Happstack.Crypto.DES, Happstack.Crypto.HMAC, Happstack.Crypto.SHA1, Happstack.Crypto.MD5, Happstack.Crypto.W64, Happstack.Util.AutoBuild, Happstack.Util.ByteStringCompat, Happstack.Util.Common, Happstack.Util.Concurrent, Happstack.Util.Cron, Happstack.Util.Daemonize, Happstack.Util.HostAddress, Happstack.Util.LogFormat, Happstack.Util.OpenExclusively, Happstack.Util.TH, Happstack.Util.FileManip if flag(tests) Build-Depends: QuickCheck >= 2 && < 2.5, HUnit Exposed-modules: Happstack.Util.Testing, Happstack.Util.Tests, Happstack.Util.Tests.HostAddress extensions: CPP, UndecidableInstances, BangPatterns, StandaloneDeriving, DeriveDataTypeable, TemplateHaskell, RecursiveDo if impl(ghc >= 6.12) ghc-options: -Wall -fno-warn-unused-do-bind else ghc-options: -Wall GHC-Prof-Options: -auto-all Executable happstack-util-tests Main-Is: Test.hs GHC-Options: -threaded hs-source-dirs: tests, src if flag(tests) Buildable: True Build-Depends: network, HUnit else Buildable: False happstack-util-6.0.0/COPYING0000644000000000000000000000267111527320401013670 0ustar0000000000000000Copyright (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. happstack-util-6.0.0/src/0000755000000000000000000000000011527320401013416 5ustar0000000000000000happstack-util-6.0.0/src/Happstack/0000755000000000000000000000000011527320401015334 5ustar0000000000000000happstack-util-6.0.0/src/Happstack/Util/0000755000000000000000000000000011527320401016251 5ustar0000000000000000happstack-util-6.0.0/src/Happstack/Util/OpenExclusively.hs0000644000000000000000000000132111527320401021740 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Cross platform way to open a file exclusively module Happstack.Util.OpenExclusively ( -- | Cross platform way to open a file exclusively openExclusively ) where import System.IO #ifdef mingw32_HOST_OS -- Windows opens files for exclusive writing by default openExclusively :: FilePath -> IO Handle openExclusively fp = openFile fp ReadWriteMode #endif #ifndef mingw32_HOST_OS import System.Posix.IO -- Unix needs to use a special open call to open files for exclusive writing openExclusively :: FilePath -> IO Handle openExclusively fp = fdToHandle =<< openFd fp ReadWrite (Just 0o600) flags where flags = defaultFileFlags {exclusive = True, trunc = True} #endif happstack-util-6.0.0/src/Happstack/Util/Testing.hs0000644000000000000000000000476511527320401020236 0ustar0000000000000000module Happstack.Util.Testing (qctest, qccheck) where import qualified Test.HUnit as HU import qualified Test.QuickCheck as QC -- import Test.QuickCheck.Batch (TestResult(..),TestOptions(..),run) import System.Random {- qccheck :: QC.Testable a => Config -> a -> Test qccheck config a = TestCase $ do rnd <- newStdGen tests config (evaluate a) rnd 0 0 [] -} qccheck :: QC.Testable a => QC.Args -> a -> HU.Test qccheck args prop = HU.TestCase $ do result <- QC.quickCheckWithResult args prop case result of (QC.Success {}) -> return () (QC.GaveUp {}) -> let ntest = QC.numTests result in HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") (QC.Failure {}) -> HU.assertFailure (QC.reason result) (QC.NoExpectedFailure {}) -> HU.assertFailure $ "No Expected Failure" qctest :: QC.Testable a => a -> HU.Test qctest = qccheck QC.stdArgs {- qcrun :: QC.Testable a => a -> TestOptions -> Test qcrun prop opts = TestCase $ do res <- run prop opts case res of (TestOk _ _ _) -> return () (TestExausted _ ntest _) -> assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") (TestFailed testArgs ntest) -> assertFailure ( "Falsifiable, after " ++ show ntest ++ " tests:\n" ++ unlines testArgs ) (TestAborted e) -> assertFailure $ "Test failed with exception: " ++ show e tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Assertion tests config gen rnd0 ntest nfail stamps | ntest == configMaxTest config = return () | nfail == configMaxFail config = assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") | otherwise = do putStr (configEvery config ntest (arguments result)) case ok result of Nothing -> tests config gen rnd1 ntest (nfail+1) stamps Just True -> tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) Just False -> assertFailure ("Falsifiable, after " ++ show ntest ++ " tests:\n" ++ unlines (arguments result) ) where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 -}happstack-util-6.0.0/src/Happstack/Util/TH.hs0000644000000000000000000000102711527320401017120 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Happstack.Util.TH where import Language.Haskell.TH -- | Version of 'instanceD' that takes in a Q [Dec] instead of a [Q Dec] -- and filters out signatures from the list of declarations instanceD' :: CxtQ -> TypeQ -> Q [Dec] -> DecQ instanceD' ctxt ty decs = do decs' <- decs let decs'' = filter (not . isSigD) decs' instanceD ctxt ty (map return decs'') -- | Returns true if the Dec matches a SigD constructor isSigD :: Dec -> Bool isSigD (SigD _ _) = True isSigD _ = False happstack-util-6.0.0/src/Happstack/Util/Cron.hs0000644000000000000000000000133111527320401017504 0ustar0000000000000000module Happstack.Util.Cron (cron) where import Control.Concurrent (threadDelay) type Seconds = Int -- | Given an action f and a number of seconds t, cron will execute -- f every t seconds with the first execution t seconds after cron is called. -- cron does not spawn a new thread. cron :: Seconds -> IO () -> IO a cron seconds0 action = loop seconds0 where maxSeconds = (maxBound :: Int) `div` 10^(6 ::Int) loop seconds = if seconds <= maxSeconds then do threadDelay (10^(6 :: Int) * seconds) action loop seconds0 else do threadDelay (10^(6 :: Int) * maxSeconds) loop (seconds - maxSeconds) happstack-util-6.0.0/src/Happstack/Util/HostAddress.hs0000644000000000000000000000231611527320401021032 0ustar0000000000000000-- Pure Haskell functions to convert HostAddress and HostAddress6 to a human -- readable string format. module Happstack.Util.HostAddress (showHostAddress, showHostAddress6, HostAddress, HostAddress6) where import Data.Word (Word32) import Numeric (showHex) import Data.List (intersperse) type HostAddress = Word32 type HostAddress6 = (Word32, Word32, Word32, Word32) -- | Converts a HostAddress to a String in dot-decimal notation showHostAddress :: HostAddress -> String showHostAddress num = concat [show q1, ".", show q2, ".", show q3, ".", show q4] where (num',q1) = num `quotRem` 256 (num'',q2) = num' `quotRem` 256 (num''',q3) = num'' `quotRem` 256 (_,q4) = num''' `quotRem` 256 -- | Converts a IPv6 HostAddress6 to standard hex notation showHostAddress6 :: HostAddress6 -> String showHostAddress6 (a,b,c,d) = (concat . intersperse ":" . map (flip showHex "")) [p1,p2,p3,p4,p5,p6,p7,p8] where (a',p2) = a `quotRem` 65536 (_,p1) = a' `quotRem` 65536 (b',p4) = b `quotRem` 65536 (_,p3) = b' `quotRem` 65536 (c',p6) = c `quotRem` 65536 (_,p5) = c' `quotRem` 65536 (d',p8) = d `quotRem` 65536 (_,p7) = d' `quotRem` 65536 happstack-util-6.0.0/src/Happstack/Util/FileManip.hs0000644000000000000000000001036511527320401020456 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Happstack.Util.FileManip (always, find) where import qualified System.PosixCompat.Files as F import Control.Monad.State import qualified Control.Exception.Extensible as E import System.IO import Data.List (sort) import System.Directory (getDirectoryContents) import System.IO.Unsafe (unsafeInterleaveIO) import System.FilePath (()) -- | Information collected during the traversal of a directory. data FileInfo = FileInfo { infoPath :: FilePath -- ^ file path , infoDepth :: Int -- ^ current recursion depth , infoStatus :: F.FileStatus -- ^ status of file } deriving (Eq) instance Eq F.FileStatus where a == b = F.deviceID a == F.deviceID b && F.fileID a == F.fileID b -- | Construct a 'FileInfo' value. mkFI :: FilePath -> Int -> F.FileStatus -> FileInfo mkFI = FileInfo -- | Monadic container for file information, allowing for clean -- construction of combinators. Wraps the 'State' monad, but doesn't -- allow 'get' or 'put'. newtype FindClause a = FC { runFC :: State FileInfo a } deriving (Functor, Monad) -- | Run the given 'FindClause' on the given 'FileInfo' and return its -- result. This can be useful if you are writing a function to pass -- to 'fold'. -- -- Example: -- -- > myFoldFunc :: a -> FileInfo -> a -- > myFoldFunc a i = let useThisFile = evalClause (fileName ==? "foo") i -- > in if useThisFile -- > then fiddleWith a -- > else a -- evalClause :: FindClause a -> FileInfo -> a evalClause = evalState . runFC evalFI :: FindClause a -> FilePath -> Int -> F.FileStatus -> a evalFI m p d s = evalClause m (mkFI p d s) type FilterPredicate = FindClause Bool type RecursionPredicate = FindClause Bool -- | List the files in the given directory, sorted, and without \".\" -- or \"..\". getDirContents :: FilePath -> IO [FilePath] getDirContents dir = (sort . filter goodName) `liftM` getDirectoryContents dir where goodName "." = False goodName ".." = False goodName _ = True -- | Search a directory recursively, with recursion controlled by a -- 'RecursionPredicate'. Lazily return a sorted list of all files -- matching the given 'FilterPredicate'. Any errors that occur are -- dealt with by the given handler. findWithHandler :: (FilePath -> E.SomeException -> IO [FilePath]) -- ^ error handler -> RecursionPredicate -- ^ control recursion into subdirectories -> FilterPredicate -- ^ decide whether a file appears in the result -> FilePath -- ^ directory to start searching -> IO [FilePath] -- ^ files that matched the 'FilterPredicate' findWithHandler errHandler recurse filter path = E.handle (errHandler path) $ F.getSymbolicLinkStatus path >>= visit path 0 where visit path' depth st = if F.isDirectory st && evalFI recurse path' depth st then unsafeInterleaveIO (traverse path' (succ depth) st) else filterPath path' depth st [] traverse dir depth dirSt = do names <- E.catch (getDirContents dir) (errHandler dir) filteredPaths <- forM names $ \name -> do let path' = dir name unsafeInterleaveIO $ E.handle (errHandler path') (F.getSymbolicLinkStatus path' >>= visit path' depth) filterPath dir depth dirSt (concat filteredPaths) filterPath path' depth st result = return $ if evalFI filter path' depth st then path':result else result -- | Search a directory recursively, with recursion controlled by a -- 'RecursionPredicate'. Lazily return a sorted list of all files -- matching the given 'FilterPredicate'. Any errors that occur are -- ignored, with warnings printed to 'stderr'. find :: RecursionPredicate -- ^ control recursion into subdirectories -> FilterPredicate -- ^ decide whether a file appears in the result -> FilePath -- ^ directory to start searching -> IO [FilePath] -- ^ files that matched the 'FilterPredicate' find = findWithHandler warnOnError where warnOnError path err = hPutStrLn stderr (path ++ ": " ++ show err) >> return [] -- | Unconditionally return 'True'. always :: FindClause Bool always = return True happstack-util-6.0.0/src/Happstack/Util/LogFormat.hs0000644000000000000000000000373111527320401020503 0ustar0000000000000000module Happstack.Util.LogFormat ( formatTimeCombined , formatRequestCombined ) where import System.Locale (defaultTimeLocale) import Data.Time.Format (FormatTime(..), formatTime) -- | Format the time as describe in the Apache combined log format. -- http://httpd.apache.org/docs/2.2/logs.html#combined -- -- The format is: -- [day/month/year:hour:minute:second zone] -- day = 2*digit -- month = 3*letter -- year = 4*digit -- hour = 2*digit -- minute = 2*digit -- second = 2*digit -- zone = (`+' | `-') 4*digit formatTimeCombined :: FormatTime t => t -> String formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" -- | Format the request as describe in the Apache combined log format. -- http://httpd.apache.org/docs/2.2/logs.html#combined -- -- The format is: "%h - %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\"" -- %h: This is the IP address of the client (remote host) which made the request to the server. -- %u: This is the userid of the person requesting the document as determined by HTTP authentication. -- %t: The time that the request was received. -- %r: The request line from the client is given in double quotes. -- %>s: This is the status code that the server sends back to the client. -- %b: The last part indicates the size of the object returned to the client, not including the response headers. -- %{Referer}: The "Referer" (sic) HTTP request header. -- %{User-agent}: The User-Agent HTTP request header. formatRequestCombined :: FormatTime t => String -> String -> t -> String -> Int -> Integer -> String -> String -> String formatRequestCombined host user time requestLine responseCode size referer userAgent = unwords [ host , user , "[" ++ formattedTime ++ "]" , show requestLine , show responseCode , show size , show referer , show userAgent ] where formattedTime = formatTimeCombined time happstack-util-6.0.0/src/Happstack/Util/Daemonize.hs0000644000000000000000000000336011527320401020522 0ustar0000000000000000module Happstack.Util.Daemonize where import System.Directory import System.Environment import System.Exit import System.Time import Control.Concurrent import Control.Exception.Extensible as E import Control.Monad.Error import Happstack.Crypto.SHA1 import Happstack.Util.Common {-- 1. don't start the app if already running. the app is already running if something has written to the daemon file recently 2. kill the app if the binary has changed since the app started --} -- Will placing the lock-file in the current directory work if we run the application from cron? daemonize :: FilePath -> IO a -> IO a daemonize binarylocation main = do startTime <- getClockTime tid1 <- exitIfAlreadyRunning startTime mId <- myThreadId tid2 <- appCheck binarylocation startTime mId main `finally` mapM killThread [tid1,tid2] where seconds n = noTimeDiff { tdSec = n } exitIfAlreadyRunning startTime = do uniqueId <- getDaemonizedId let name = ".haskell_daemon." ++ uniqueId fe <- doesFileExist name when fe $ do daemonTime <- getModificationTime name when (diffClockTimes startTime daemonTime < seconds 2) $ exitWith ExitSuccess >> return () periodic (repeat 1) $ writeFile name "daemon" appCheck bl startTime mId = periodic (repeat 1) $ do fe <- doesFileExist bl if not fe then return () else do appModTime <- getModificationTime bl when (startTime < appModTime) (E.throwTo mId ExitSuccess) -- throws to the main thread getDaemonizedId :: IO String getDaemonizedId = do prog <- getProgName args <- getArgs return (sha1 (prog ++ unwords args)) happstack-util-6.0.0/src/Happstack/Util/Common.hs0000644000000000000000000001403011527320401020033 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Happstack.Util.Common -- Copyright : (c) Happstack.com, 2009; (c) HAppS.org, 2005 -- License : BSD3 -- -- -- Various helper routines. ----------------------------------------------------------------------------- module Happstack.Util.Common where import System.Log.Logger import Control.Concurrent import Control.Monad import qualified Data.ByteString.Char8 as P import Data.Char import Data.Int import System.IO import System.Exit import System.IO.Error import System.Process import System.IO.Unsafe import System.Time import Control.Arrow (first,second) type Seconds = Int type EpochSeconds = Int64 epochSeconds :: CalendarTime -> EpochSeconds epochSeconds ct = let TOD sec _ = toClockTime ct in fromIntegral sec eSecsToCalTime :: EpochSeconds -> IO CalendarTime eSecsToCalTime s = toCalendarTime (TOD (fromIntegral s) 0) epochPico :: CalendarTime -> Integer epochPico ct = fromIntegral (epochSeconds ct) * 1000 ----reliable getline and putline logMC :: Priority -> String -> IO () logMC = logM "Happstack.Util.Common" -- | Put a line into a handle followed by "\r\n" and echo to stdout hPutLine :: Handle -> String -> IO () hPutLine handle line = do hPutStr handle line hPutStr handle "\r\n" hFlush handle logMC DEBUG line return () -- | Get a line from the handle and echo to stdout hGetLn :: Handle -> IO String hGetLn handle = do let hGetLn' = do c <- hGetChar handle case c of '\n' -> return [] '\r' -> do c2 <- hGetChar handle if c2 == '\n' then return [] else getRest c _ -> getRest c getRest c = fmap (c:) hGetLn' line <- hGetLn' logMC DEBUG line return line unBracket, ltrim, rtrim, trim :: String -> String -- | Removes the whitespace surrounding a string as well -- as the first and last character. -- @unBracket " (asdf) " = "asdf"@ unBracket = tail . init . trim -- | Drops the whitespace at the start of the string ltrim = dropWhile isSpace -- | Drops the whitespace at the end of the string rtrim = reverse.ltrim.reverse -- | Trims the beginning and ending whitespace of a string trim=ltrim.rtrim -- | Repeadly splits a list by the provided separator and collects the results splitList :: Eq a => a -> [a] -> [[a]] splitList _ [] = [] splitList sep list = h:splitList sep t where (h,t)=split (==sep) list -- | Repeatedly splits a list and collects the results splitListBy :: (a -> Bool) -> [a] -> [[a]] splitListBy _ [] = [] splitListBy f list = h:splitListBy f t where (h,t)=split f list -- | Split is like break, but the matching element is dropped. split :: (a -> Bool) -> [a] -> ([a], [a]) split f s = (left,right) where (left,right')=break f s right = if null right' then [] else tail right' -- | Read file with a default value if the file does not exist. mbReadFile :: a -> (String -> a) -> FilePath -> IO a mbReadFile noth just path = (do text <- readFile path;return $ just text) `catch` \err -> if isDoesNotExistError err then return noth else ioError err mapFst :: (a -> b) -> [(a,x)] -> [(b,x)] mapFst = map . first mapSnd :: (a -> b) -> [(x,a)] -> [(x,b)] mapSnd = map . second -- | applies the list of functions to the provided argument revmap :: a -> [a -> b] -> [b] revmap item = map (\f->f item) -- | @comp f a b@ compares @a@ and @b@ after apply -- @f@. comp :: Ord t => (a -> t) -> a -> a -> Ordering comp f e1 e2 = f e1 `compare` f e2 -- | Run an external command. Upon failure print status -- to stderr. runCommand :: String -> [String] -> IO () runCommand cmd args = do (_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing let pGetContents h = do mv <- newEmptyMVar let put [] = putMVar mv [] put xs = last xs `seq` putMVar mv xs forkIO (hGetContents h >>= put) takeMVar mv os <- pGetContents outP es <- pGetContents errP ec <- waitForProcess pid case ec of ExitSuccess -> return () ExitFailure e -> do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")") hPutStrLn stderr os hPutStrLn stderr es hPutStrLn stderr "Raising error..." fail "Running external command failed" -- | Unsafe tracing, outputs the message and the value to stderr. debug :: Show a => String -> a -> a debug msg s = seq (unsafePerformIO (hPutStr stderr ("DEBUG: "++msg++"\n") >> hPutStr stderr (show s++"\n"))) s {-# NOINLINE debugM #-} -- | Unsafe tracing messages inside a monad. debugM :: Monad m => String -> m () debugM msg = unsafePerformIO (P.hPutStr stderr (P.pack (msg++"\n")) >> hFlush stderr) `seq` return () -- | Read in any monad. readM :: (Monad m, Read t) => String -> m t readM s = case reads s of [(v,"")] -> return v _ -> fail "readM: parse error" -- | Convert Maybe into an another monad. This is a simple injection that calls -- fail when given a Nothing. maybeM :: Monad m => Maybe a -> m a maybeM (Just x) = return x maybeM _ = fail "maybeM: Nothing" -- | Lifts a bool into a MonadPlus, with False mapped to the mzero. boolM :: (MonadPlus m) => Bool -> m Bool boolM False = mzero boolM True = return True -- | @notMb a b@ returns @Just a@ if @b@ is @Nothing@ and @Nothing@ if -- @b@ is @Just _@. notMb :: a-> Maybe a-> Maybe a notMb v1 v2 = maybe (Just v1) (const Nothing) v2 -- | Takes a list of delays, in seconds, and an action to execute -- repeatedly. The action is then executed repeatedly in a separate thread -- until the list has been consumed. The first action takes place immediately. periodic :: [Int] -> IO () -> IO ThreadId periodic ts = forkIO . periodic' ts -- a little something to fix the types of ^ infixr 8 .^ (.^) :: Int->Int->Int a .^ b = a ^ b -- | Similar to 'periodic' but runs in the same thread periodic' :: [Int] -> IO a -> IO a periodic' [] x = x periodic' (t:ts) x = x >> threadDelay ((10 .^ 6)*t) >> periodic' ts x happstack-util-6.0.0/src/Happstack/Util/AutoBuild.hs0000644000000000000000000000611311527320401020476 0ustar0000000000000000------------------------------------------------------------------------------- -- | -- Module : Happstack.Util.AutoBuild -- Copyright : Happstack.com 2009 -- License : BSD3 -- -- Maintainer : Matthew Elder -- Stability : provisional -- Portability : linux/windows -- ------------------------------------------------------------------------------- module Happstack.Util.AutoBuild ( autoBuild ) where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) import Control.Exception (bracket) import System.Directory (getModificationTime) import System.Exit (ExitCode(..), exitFailure) import System.Process import System.Time (ClockTime) import System.IO -- | Functionality for the autoBuild tool. -- Inspired by searchpath. autoBuild :: String -- ^ Build command -> String -- ^ Path to binary -> [String] -- ^ Arguments to use when running binary -> IO () autoBuild buildCmd binPath binArgs = do putStrLn "Performing the initial build. . ." buildSuccess <- buildBin buildCmd -- initial build if buildSuccess then do mph <- newEmptyMVar newMod <- getModificationTime binPath forkIO (builder mph buildCmd binPath newMod) runner mph binPath binArgs else do putStrLn "Initial build failed, see 'build.out.log' and 'build.err.log'." exitFailure -- builds the program builder :: MVar ProcessHandle -> String -> FilePath -> ClockTime -> IO () builder mph buildCmd binPath lastMod = do -- add a delay between build attempts (5 seconds) threadDelay 5000000 buildSuccess <- buildBin buildCmd newMod <- getModificationTime binPath -- if the build yielded a new binary, terminate the process if buildSuccess && (newMod /= lastMod) then do putStrLn "A new binary has been built, killing the existing one. . ." terminateProcess =<< takeMVar mph else return () -- continue loop builder mph buildCmd binPath newMod -- runs the program runner :: MVar ProcessHandle -> FilePath -> [String] -> IO () runner mph binPath binArgs = do bracket (runBin binPath binArgs) (terminateProcess) (\ph -> putMVar mph ph >> waitForProcess ph) -- continue loop runner mph binPath binArgs -- does not block, returns ph runBin :: String -> [String] -> IO ProcessHandle runBin binPath binArgs = do putStrLn $ "Running binary: " ++ (showCmd binPath binArgs) ph <- runProcess binPath binArgs Nothing Nothing Nothing Nothing Nothing return ph where showCmd bp [] = bp showCmd bp ba = bp ++ " " ++ unwords ba -- blocks until built, returns True if build was a success buildBin :: String -> IO Bool buildBin buildCmd = do (_inp,out,err,ph) <- runInteractiveCommand buildCmd appendFile "build.out.log" =<< hGetContents out appendFile "build.err.log" =<< hGetContents err waitForProcess ph exitCode <- getProcessExitCode ph return (exitCode == Just ExitSuccess) happstack-util-6.0.0/src/Happstack/Util/ByteStringCompat.hs0000644000000000000000000000450211527320401022044 0ustar0000000000000000{-# OPTIONS -cpp #-} -- | Compatiblity for ByteStrings module Happstack.Util.ByteStringCompat (breakChar, breakCharEnd, dropSpace, dropSpaceEnd, rechunkLazy ) where import Data.ByteString(ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as L import Data.Char(isSpace) import Foreign #define STRICT2(f) f a b | a `seq` b `seq` False = undefined -- | Semantically equivalent to break on strings {-# INLINE breakChar #-} breakChar :: Char -> ByteString -> (ByteString, ByteString) breakChar ch = B.break ((==) x) where x = B.c2w ch -- | 'breakCharEnd' behaves like breakChar, but from the end of the -- ByteString. -- -- > breakCharEnd ('b') (pack "aabbcc") == ("aab","cc") -- -- and the following are equivalent: -- -- > breakCharEnd 'c' "abcdef" -- > let (x,y) = break (=='c') (reverse "abcdef") -- > in (reverse (drop 1 y), reverse x) -- {-# INLINE breakCharEnd #-} breakCharEnd :: Char -> ByteString -> (ByteString, ByteString) breakCharEnd c p = B.breakEnd ((==) x) p where x = B.c2w c -- | Drops leading spaces in the ByteString {-# INLINE dropSpace #-} dropSpace :: ByteString -> ByteString dropSpace = C.dropWhile isSpace -- | Drops trailing spaces in the ByteString {-# INLINE dropSpaceEnd #-} dropSpaceEnd :: ByteString -> ByteString dropSpaceEnd (B.PS x s l) = B.inlinePerformIO $ withForeignPtr x $ \p -> do i <- lastnonspace (p `plusPtr` s) (l-1) return $! if i == (-1) then B.empty else B.PS x s (i+1) lastnonspace :: Ptr Word8 -> Int -> IO Int STRICT2(lastnonspace) lastnonspace ptr n | n < 0 = return n | otherwise = do w <- peekElemOff ptr n if B.isSpaceWord8 w then lastnonspace ptr (n-1) else return n -- | Chunk a lazy bytestring into reasonable chunks - is id from outside. -- This is useful to make bytestring chunks reasonable sized for e.g. -- compression. rechunkLazy :: L.ByteString -> L.ByteString rechunkLazy = L.fromChunks . norm . foldr w ([],[],0) . L.toChunks where norm (acc, [], _) = acc norm (acc, cur, _) = B.concat cur : acc w chunk (acc,cur,len) = let bl = len + B.length chunk in if bl > 0x100 then (B.concat (chunk : cur) : acc, [], 0) else (acc, chunk : cur, bl) happstack-util-6.0.0/src/Happstack/Util/Concurrent.hs0000644000000000000000000000512211527320401020727 0ustar0000000000000000{-# OPTIONS -cpp #-} {- Copyright (c) Happstack.com, 2009; (c) HAppS.org, 2005 Using Happstack in GHCi Because there are many threads and reloading everything is slow here is a way to kill all threads from GHCi: add -DINTERACTIVE to the command line and use the function happsKill from the prompt. -} module Happstack.Util.Concurrent where import Control.Concurrent import Prelude hiding (catch) import Control.Exception -- hiding (catch) #ifdef INTERACTIVE import System.IO.Unsafe import System.Mem #endif --generic utils -- | Equivalent to a composition of fork and foreverSt forkEverSt :: (t -> IO t) -> t -> IO ThreadId forkEverSt f = fork . foreverSt f -- | Similar to forever but with an explicit state parameter threaded through -- the computation. foreverSt :: (Monad m) => (t -> m t) -> t -> m b foreverSt f state= f state >>= foreverSt f -- | Equivalent to a composition of fork and forever forkEver :: IO a -> IO ThreadId forkEver = fork . forever -- | Lifts the argument with Right before writing it into the chan writeChanRight :: Chan (Either a b) -> b -> IO () writeChanRight chan = writeChan chan . Right -- | Lifts the argument with Left before writing it into the chan writeChanLeft :: Chan (Either a b) -> a -> IO () writeChanLeft chan = writeChan chan . Left -- | Fork that throws away the ThreadId fork_ :: IO a -> IO () fork_ c = fork c >> return () -- | Fork a new thread. fork :: IO a -> IO ThreadId -- | Register an action to be run when ghci is restarted. registerResetAction :: IO () -> IO () -- | Reset state reset :: IO () -- | A version of forever that will gracefully catch IO exceptions and continue -- executing the provided action. forever :: IO a -> IO a #ifndef INTERACTIVE forever a = finally a (forever a) fork c = forkIO (c >> return ()) registerResetAction _ = return () reset = return () #else forever a = try a >>= w where w (Right _) = forever a w (Left (AsyncException ThreadKilled)) = return () w (Left e) = print e >> forever a registerResetAction x = modifyMVar_ happsThreadList (return . (x:)) fork c = do x <- forkIO (c >> return ()) modifyMVar_ happsThreadList (\xs -> return (killThread x:xs)) return x reset = do xs <- swapMVar happsThreadList [] sequence_ xs threadDelay 10000 performGC logM "Happstack.Util.Concurrent" INFO "reset ok" {-# NOINLINE happsThreadList #-} happsThreadList = unsafePerformIO $ newMVar [] #endif -- | Sleep N seconds sleep :: Int -> IO () sleep n = threadDelay (n * second) where second = 1000000 happstack-util-6.0.0/src/Happstack/Crypto/0000755000000000000000000000000011527320401016614 5ustar0000000000000000happstack-util-6.0.0/src/Happstack/Crypto/MD5.hs0000644000000000000000000002033311527320401017536 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- Module : Happstack.Crypto.MD5 -- License : BSD3 -- Maintainer : lemmih@vo.com -- Author : Thomas.DuBuisson@mail.google.com -- Stability : experimental -- Portability : portable, requires bang patterns and ByteString -- Tested with : GHC-6.8.1 -- module Happstack.Crypto.MD5 (md5 ,md5InitialContext ,md5Update ,md5Finalize ,MD5Context ,md5File ,stringMD5 ,applyMD5Rounds ,test ) where import Prelude hiding ((!!)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal import Data.Bits import Data.List hiding ((!!)) import Data.Int(Int64) import Data.Word import Foreign.Storable import Foreign.Ptr import Foreign.ForeignPtr import Numeric import System.Environment() import System.IO blockSize :: Int blockSize = 512 -- Block size in bits blockSizeBytes :: Int blockSizeBytes = blockSize `div` 8 blockSizeBytesW64 :: Int64 blockSizeBytesW64 = fromIntegral blockSizeBytes blockSizeBits :: Word64 blockSizeBits = fromIntegral blockSize data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 data MD5Context = MD5Ctx { mdPartial :: MD5Partial, mdLeftOver :: ByteString, mdTotalLen :: Word64 } md5InitialContext :: MD5Context md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 h0, h1, h2, h3 :: Word32 h0 = 0x67452301 h1 = 0xEFCDAB89 h2 = 0x98BADCFE h3 = 0x10325476 -- | Will read the lazy ByteString and return the md5 digest. -- Some application might want to wrap this function for type safty. md5 :: L.ByteString -> L.ByteString md5 bs = md5Finalize $ md5Update md5InitialContext bs md5Finalize :: MD5Context -> L.ByteString md5Finalize !ctx@(MD5Ctx (MD5Par _ _ _ _) r !totLen) = let totLen' = (totLen + 8*fromIntegral l) :: Word64 padBS = B.pack $ 0x80 : replicate lenZeroPad 0 ++ size_split 8 totLen' (MD5Ctx (MD5Par a' b' c' d') _ _) = md5Update ctx (L.fromChunks [r,padBS]) in L.pack $ concatMap (size_split 4) [a',b',c',d'] where l = B.length r lenZeroPad = if (l+1) <= blockSizeBytes - 8 then (blockSizeBytes - 8) - (l+1) else (2*blockSizeBytes - 8) - (l+1) size_split :: (Integral t, Num a) => Int -> t -> [a] size_split 0 _ = [] size_split p n = (fromIntegral d):size_split (p-1) n' where (n', d) = divMod n 256 md5Update :: MD5Context -> L.ByteString -> MD5Context md5Update ctx bsLazy = let _ = L.toChunks bsLazy blks = block bsLazy in foldl' performMD5Update ctx blks block :: L.ByteString -> [ByteString] block bs = case L.toChunks bs of [] -> [] _ -> (B.concat . L.toChunks) top : block rest where (top,rest) = L.splitAt blockSizeBytesW64 bs {-# INLINE block #-} -- Assumes ByteString length == blockSizeBytes, will fold the -- context across calls to applyMD5Rounds. performMD5Update :: MD5Context -> ByteString -> MD5Context performMD5Update !ctx@(MD5Ctx !par@(MD5Par !a !b !c !d) _ !len) bs = let MD5Par a' b' c' d' = applyMD5Rounds par bs in if B.length bs == blockSizeBytes then MD5Ctx { mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), mdLeftOver = B.empty, mdTotalLen = len + blockSizeBits } else ctx { mdLeftOver = bs } applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial applyMD5Rounds (MD5Par a b c d) w = let -- Round 1 !r0 = ff a b c d (w!!0) 7 3614090360 !r1 = ff d r0 b c (w!!1) 12 3905402710 !r2 = ff c r1 r0 b (w!!2) 17 606105819 !r3 = ff b r2 r1 r0 (w!!3) 22 3250441966 !r4 = ff r0 r3 r2 r1 (w!!4) 7 4118548399 !r5 = ff r1 r4 r3 r2 (w!!5) 12 1200080426 !r6 = ff r2 r5 r4 r3 (w!!6) 17 2821735955 !r7 = ff r3 r6 r5 r4 (w!!7) 22 4249261313 !r8 = ff r4 r7 r6 r5 (w!!8) 7 1770035416 !r9 = ff r5 r8 r7 r6 (w!!9) 12 2336552879 !r10 = ff r6 r9 r8 r7 (w!!10) 17 4294925233 !r11 = ff r7 r10 r9 r8 (w!!11) 22 2304563134 !r12 = ff r8 r11 r10 r9 (w!!12) 7 1804603682 !r13 = ff r9 r12 r11 r10 (w!!13) 12 4254626195 !r14 = ff r10 r13 r12 r11 (w!!14) 17 2792965006 !r15 = ff r11 r14 r13 r12 (w!!15) 22 1236535329 -- Round 2 !r16 = gg r12 r15 r14 r13 (w!!1) 5 4129170786 !r17 = gg r13 r16 r15 r14 (w!!6) 9 3225465664 !r18 = gg r14 r17 r16 r15 (w!!11) 14 643717713 !r19 = gg r15 r18 r17 r16 (w!!0) 20 3921069994 !r20 = gg r16 r19 r18 r17 (w!!5) 5 3593408605 !r21 = gg r17 r20 r19 r18 (w!!10) 9 38016083 !r22 = gg r18 r21 r20 r19 (w!!15) 14 3634488961 !r23 = gg r19 r22 r21 r20 (w!!4) 20 3889429448 !r24 = gg r20 r23 r22 r21 (w!!9) 5 568446438 !r25 = gg r21 r24 r23 r22 (w!!14) 9 3275163606 !r26 = gg r22 r25 r24 r23 (w!!3) 14 4107603335 !r27 = gg r23 r26 r25 r24 (w!!8) 20 1163531501 !r28 = gg r24 r27 r26 r25 (w!!13) 5 2850285829 !r29 = gg r25 r28 r27 r26 (w!!2) 9 4243563512 !r30 = gg r26 r29 r28 r27 (w!!7) 14 1735328473 !r31 = gg r27 r30 r29 r28 (w!!12) 20 2368359562 -- Round 3 !r32 = hh r28 r31 r30 r29 (w!!5) 4 4294588738 !r33 = hh r29 r32 r31 r30 (w!!8) 11 2272392833 !r34 = hh r30 r33 r32 r31 (w!!11) 16 1839030562 !r35 = hh r31 r34 r33 r32 (w!!14) 23 4259657740 !r36 = hh r32 r35 r34 r33 (w!!1) 4 2763975236 !r37 = hh r33 r36 r35 r34 (w!!4) 11 1272893353 !r38 = hh r34 r37 r36 r35 (w!!7) 16 4139469664 !r39 = hh r35 r38 r37 r36 (w!!10) 23 3200236656 !r40 = hh r36 r39 r38 r37 (w!!13) 4 681279174 !r41 = hh r37 r40 r39 r38 (w!!0) 11 3936430074 !r42 = hh r38 r41 r40 r39 (w!!3) 16 3572445317 !r43 = hh r39 r42 r41 r40 (w!!6) 23 76029189 !r44 = hh r40 r43 r42 r41 (w!!9) 4 3654602809 !r45 = hh r41 r44 r43 r42 (w!!12) 11 3873151461 !r46 = hh r42 r45 r44 r43 (w!!15) 16 530742520 !r47 = hh r43 r46 r45 r44 (w!!2) 23 3299628645 -- Round 4 !r48 = ii r44 r47 r46 r45 (w!!0) 6 4096336452 !r49 = ii r45 r48 r47 r46 (w!!7) 10 1126891415 !r50 = ii r46 r49 r48 r47 (w!!14) 15 2878612391 !r51 = ii r47 r50 r49 r48 (w!!5) 21 4237533241 !r52 = ii r48 r51 r50 r49 (w!!12) 6 1700485571 !r53 = ii r49 r52 r51 r50 (w!!3) 10 2399980690 !r54 = ii r50 r53 r52 r51 (w!!10) 15 4293915773 !r55 = ii r51 r54 r53 r52 (w!!1) 21 2240044497 !r56 = ii r52 r55 r54 r53 (w!!8) 6 1873313359 !r57 = ii r53 r56 r55 r54 (w!!15) 10 4264355552 !r58 = ii r54 r57 r56 r55 (w!!6) 15 2734768916 !r59 = ii r55 r58 r57 r56 (w!!13) 21 1309151649 !r60 = ii r56 r59 r58 r57 (w!!4) 6 4149444226 !r61 = ii r57 r60 r59 r58 (w!!11) 10 3174756917 !r62 = ii r58 r61 r60 r59 (w!!2) 15 718787259 !r63 = ii r59 r62 r61 r60 (w!!9) 21 3951481745 in MD5Par r60 r63 r62 r61 where f !x !y !z = (x .&. y) .|. ((complement x) .&. z) {-# INLINE f #-} g !x !y !z = (x .&. z) .|. (y .&. (complement z)) {-# INLINE g #-} h !x !y !z = (x `xor` y `xor` z) {-# INLINE h #-} i !x !y !z = y `xor` (x .|. (complement z)) {-# INLINE i #-} ff a_ b_ c_ d_ x s ac = {-# SCC "ff" #-} let !a' = f b_ c_ d_ + x + ac + a_ !a'' = rotateL a' s in a'' + b_ {-# INLINE ff #-} gg a_ b_ c_ d_ x s ac = {-# SCC "gg" #-} let !a' = g b_ c_ d_ + x + ac + a_ !a'' = rotateL a' s in a'' + b_ {-# INLINE gg #-} hh a_ b_ c_ d_ x s ac = {-# SCC "hh" #-} let !a' = h b_ c_ d_ + x + ac + a_ !a'' = rotateL a' s in a'' + b_ {-# INLINE hh #-} ii a_ b_ c_ d_ x s ac = {-# SCC "ii" #-} let !a' = i b_ c_ d_ + x + ac + a_ !a'' = rotateL a' s in a'' + b_ {-# INLINE ii #-} (!!) word32s pos = getNthWord pos word32s {-# INLINE (!!) #-} getNthWord n (PS ptr off _) = inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do let p = castPtr $ plusPtr ptr' off peekElemOff p n {-# INLINE getNthWord #-} {-# INLINE applyMD5Rounds #-} stringMD5 :: L.ByteString -> String stringMD5 lazy = let x = L.toChunks lazy w = B.unpack (B.concat x) s = map (\v -> showHex v "") w s' = map (\v -> if length v == 1 then '0':v else v) s in concat s' test :: IO () test = do let h = md5 $ L.pack [] putStrLn $ "Hash is: " ++ (stringMD5 h) putStrLn $ "Should Be: d41d8cd98f00b204e9800998ecf8427e" md5File :: String -> IO () md5File f = do h <- openFile f ReadMode s <- L.hGetContents h let hash = md5 s putStrLn (stringMD5 hash) return () happstack-util-6.0.0/src/Happstack/Crypto/W64.hs0000644000000000000000000000531111527320401017530 0ustar0000000000000000{-# LANGUAGE CPP, UndecidableInstances #-} module Happstack.Crypto.W64 where import Happstack.Crypto.DES import Happstack.Crypto.SHA1 import Data.List import Numeric(readHex) #ifdef TEST import Test.QuickCheck #endif --the first character to be encrypted is 0 1 2 3 the number that should --be ignored at the end of the string pad :: String -> String pad x = padding++x where padLength = 4 - (length x) `mod` 4 padding = (toEnum padLength) : (replicate (padLength-1) 'A') unpad :: (Enum a) => [a] -> [a] unpad x = drop (fromEnum $ head x) x prop_PadUnPad :: String -> Bool prop_PadUnPad x = x==(unpad $ pad x) is4Char :: [a] -> Bool is4Char x = length x==4 quadCharToW64 :: (Num b, Enum a) => [a] -> b quadCharToW64 = fromInteger . impl . map (fromIntegral.fromEnum) where impl :: [Integer] -> Integer impl [a,b,c,d]=(a*2^24+b*2^16+c*2^8+d) impl _ = error "Argument to quadCharToW64 must be length 4" w64ToQuadChar :: (Integral a, Enum b) => a -> [b] w64ToQuadChar w64 = map (toEnum.fromIntegral) $! reverse $! take 4 $! v ++ (repeat 0) where v = w64ToQuadNum w64 w64ToQuadNum :: (Integral a) => a -> [a] w64ToQuadNum = unfoldr (\x->if x==0 then Nothing else Just (x `mod` 256,x `div` 256)) #ifdef TEST prop_quadCharW64 x = is4Char x ==> x == (w64ToQuadChar $ quadCharToW64 x) #endif --assume padded toQuadChars :: [a] -> [[a]] toQuadChars [] = [] toQuadChars (a:b:c:d:rest) = [a,b,c,d]:toQuadChars rest toQuadChars _ = error "Argument for toQuadChars must have a length that is a multiple of 4" stringToW64s :: (Num a) => String -> [a] stringToW64s = map quadCharToW64 . toQuadChars . pad w64sToString :: (Enum b) => [Integer] -> [b] w64sToString = unpad . concatMap w64ToQuadChar prop_stringW64 :: String -> Bool prop_stringW64 x = x == (w64sToString $ stringToW64s x) --des takes a 64 bit number and encrypts it with another 64 bit number --so string DES is an key string converted to a w64 and a value converted --to a list of w64s --the result is then converted from a list of w64s back to a string --the key is an sha1 hash of the string converted to a 64 bit int or -- the first 16 hex digits -- `1/3 of total key space hexToW64 :: (Num a) => String -> a hexToW64 = fromInteger . fst . head . readHex . take 16 stringToKey :: (Num a) => String -> a stringToKey = hexToW64 . sha1 des_encrypt :: String -> String -> [Enc] des_encrypt key = map (flip des_enc $ stringToKey key) . stringToW64s des_decrypt :: (Enum a) => String -> [Message] -> [a] des_decrypt key = w64sToString . map (toInteger . flip des_dec (stringToKey key)) prop_DES :: String -> String -> Bool prop_DES key val = val == (des_decrypt key $ des_encrypt key val) happstack-util-6.0.0/src/Happstack/Crypto/SHA1.lhs0000644000000000000000000001444711527320401020032 0ustar0000000000000000{-- Copyright (C) 2001 Ian Lynagh SHA.lhs can be used under either the BSD or GPL. http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ Copyright (c) The Regents of the University of California. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --} > module Happstack.Crypto.SHA1 (sha1, sha1Raw, sha1_size) where > import Data.Char > import Data.Bits > import Data.Word > type ABCDE = (Word32, Word32, Word32, Word32, Word32) > type XYZ = (Word32, Word32, Word32) > type Rotation = Int > sha1 :: String -> String > sha1 s = s5 > where s1_2 = sha1_step_1_2_pad_length s > abcde = sha1_step_3_init > abcde' = sha1_step_4_main abcde s1_2 > s5 = sha1_step_5_display abcde' > sha1Raw :: String -> String > sha1Raw s = s5 > where s1_2 = sha1_step_1_2_pad_length s > abcde = sha1_step_3_init > abcde' = sha1_step_4_main abcde s1_2 > s5 = sha1_step_5_concat abcde' > sha1_size :: (Integral a) => a -> String -> String > sha1_size l s = s5 > where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64::Integer))) "" > abcde = sha1_step_3_init > abcde' = sha1_step_4_main abcde s1_2 > s5 = sha1_step_5_display abcde' > sha1_step_1_2_pad_length :: String -> String > sha1_step_1_2_pad_length = sha1_step_1_2_work 0 > sha1_step_1_2_work :: Integer -> String -> String > sha1_step_1_2_work c64 "" = padding ++ len > where padding = '\128':replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) '\000' > len = map chr $ size_split 8 c64 > sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work (((c64 + 8) `mod` (2^64))::Integer) cs > replicate' :: Word16 -> a -> [a] > replicate' 0 _ = [] > replicate' n x = x:replicate' (n-1) x > size_split :: Int -> Integer -> [Int] > size_split 0 _ = [] > size_split p n = size_split (p-1) n' ++ [fromIntegral d] > where (n', d) = divMod n 256 > sha1_step_3_init :: ABCDE > sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0) [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] wm3 = [13,14,15] wm8 = [8,9,10,11,12,13,14,15] wm14 = [2,3,4,5,6,7,8,9,10,11,12,13,14,15] wm16 = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] > sha1_step_4_main :: ABCDE -> String -> ABCDE > sha1_step_4_main abcde "" = {- abcde -} abcde > sha1_step_4_main abcde0 s = sha1_step_4_main abcde5 s' > where (s64, s') = takeDrop 64 s > s16 = get_word_32s s64 > s80 = s16 ++ sha1_add_ws 16 (drop 13 s16, drop 8 s16, drop 2 s16, s16) > (s20_0, s60) = takeDrop 20 s80 > (s20_1, s40) = takeDrop 20 s60 > (s20_2, s20_3) = takeDrop 20 s40 > abcde1 = foldl (doit f1 0x5a827999) abcde0 s20_0 > abcde2 = foldl (doit f2 0x6ed9eba1) abcde1 s20_1 > abcde3 = foldl (doit f3 0x8f1bbcdc) abcde2 s20_2 > abcde4 = foldl (doit f2 0xca62c1d6) abcde3 s20_3 > f1 (x, y, z) = (x .&. y) .|. ((complement x) .&. z) > f2 (x, y, z) = x `xor` y `xor` z > f3 (x, y, z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) > (a, b, c, d, e ) = abcde0 > (a', b', c', d', e') = abcde4 > abcde5 = (a + a', b + b', c + c', d + d', e + e') > doit :: (XYZ -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE > doit f k (a, b, c, d, e) w = (a', a, rotL b 30, c, d) > where a' = rotL a 5 + f(b, c, d) + e + w + k > sha1_add_ws :: Int -> ([Word32], [Word32], [Word32], [Word32]) -> [Word32] > sha1_add_ws 80 _ = [] > sha1_add_ws n (w1:w1s, w2:w2s, w3:w3s, w4:w4s) > = w:sha1_add_ws (n + 1) (w1s ++ [w], w2s ++ [w], w3s ++ [w], w4s ++ [w]) > where w = rotL (foldr1 xor [w1, w2, w3, w4]) 1 > sha1_add_ws _ _ = error "Case not defined in sha1_add_ws" > > get_word_32s :: String -> [Word32] > get_word_32s "" = [] > get_word_32s ss = this:rest > where (s, ss') = takeDrop 4 ss > this = sum $ zipWith shiftL (map (fromIntegral.ord) s) [24, 16, 8, 0] > rest = get_word_32s ss' > takeDrop :: Int -> [a] -> ([a], [a]) > takeDrop _ [] = ([], []) > takeDrop 0 xs = ([], xs) > takeDrop n (x:xs) = (x:ys, zs) > where (ys, zs) = takeDrop (n-1) xs > sha1_step_5_display :: ABCDE -> String > sha1_step_5_display (a, b, c, d, e) > = foldr (\x y -> display_32bits_as_hex x ++ y) "" [a, b, c, d, e] > sha1_step_5_concat :: ABCDE -> String > sha1_step_5_concat (a, b, c, d, e) > = foldr (\x y -> display_32bits_as_8bits x y) "" [a, b, c, d, e] > display_32bits_as_hex :: Word32 -> String > display_32bits_as_hex x0 = map getc [y8,y7,y6,y5,y4,y3,y2,y1] > where (x1, y1) = divMod x0 16 > (x2, y2) = divMod x1 16 > (x3, y3) = divMod x2 16 > (x4, y4) = divMod x3 16 > (x5, y5) = divMod x4 16 > (x6, y6) = divMod x5 16 > (y8, y7) = divMod x6 16 > getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) > display_32bits_as_8bits :: Word32 -> ShowS > display_32bits_as_8bits x0 l > = getn 3 : getn 2 : getn 1 : getn 0 : l > where getn n = chr (fromIntegral (x0 `shiftR` (n*8) .&. 0xFF)) > rotL :: Word32 -> Rotation -> Word32 > rotL a s = shiftL a s .|. shiftL a (s-32) happstack-util-6.0.0/src/Happstack/Crypto/Base64.hs0000644000000000000000000001077011527320401020201 0ustar0000000000000000-- BSDLicensed -- Copyright (c) 2002, Warrick Gray All rights reserved. -- See http://www.ietf.org/rfc/rfc2045.txt for definition. module Happstack.Crypto.Base64 ( encode, decode, chop72 ) where {- The following properties should hold: decode . encode = id decode . chop72 . encode = id I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, the second variation corresponds better with the RFC above, but outside of MIME applications might be undesireable. But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only 8 significant bits, which is more than enough for US-ASCII. -} import Data.Array.Unboxed import Data.Bits import Data.Char (chr,ord) encodeArray :: UArray Int Char encodeArray = array (0,64) [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] -- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) -- clearly the upmost/leftmost 8 bits of the answer are 0. -- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :( int4_char3 :: [Int] -> [Char] int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) in (chr (n `shiftR` 16 .&. 0xff)) : (chr (n `shiftR` 8 .&. 0xff)) : (chr (n .&. 0xff)) : int4_char3 t int4_char3 [a,b,c] = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) in [ (chr (n `shiftR` 16 .&. 0xff)) , (chr (n `shiftR` 8 .&. 0xff)) ] int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12) in [ (chr (n `shiftR` 16 .&. 0xff)) ] int4_char3 [] = [] int4_char3 _ = error "Case not implemented in int4_char3" -- Convert triplets of characters to -- 4 base64 integers. The last entries -- in the list may not produce 4 integers, -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers. char3_int4 :: [Char] -> [Int] char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t char3_int4 [a,b] = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) in [ (n `shiftR` 18 .&. 0x3f) , (n `shiftR` 12 .&. 0x3f) , (n `shiftR` 6 .&. 0x3f) ] char3_int4 [a] = let n = (ord a `shiftL` 16) in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] char3_int4 [] = [] -- Retrieve base64 char, given an array index integer in the range [0..63] enc1 :: Int -> Char enc1 ch = encodeArray!ch -- | Cut up a string into 72 char lines, each line terminated by CRLF. chop72 :: String -> String chop72 str = let (bgn,end) = splitAt 70 str in if null end then bgn else bgn ++ "\r\n" ++ chop72 end -- Pads a base64 code to a multiple of 4 characters, using the special -- '=' character. quadruplets :: String -> String quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit quadruplets [] = [] -- 24bit tail unit quadruplets _ = error "Case not implemented in quadruplets" enc :: [Int] -> [Char] enc = quadruplets . map enc1 dcd :: String -> [Int] dcd [] = [] dcd (h:t) | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t | h == '+' = 62 : dcd t | h == '/' = 63 : dcd t | h == '=' = [] -- terminate data stream | otherwise = dcd t -- Principal encoding and decoding functions. encode, decode :: String -> String encode = enc . char3_int4 decode = int4_char3 . dcd happstack-util-6.0.0/src/Happstack/Crypto/HMAC.hs0000644000000000000000000000102111527320401017652 0ustar0000000000000000module Happstack.Crypto.HMAC where import Happstack.Crypto.SHA1 import Happstack.Crypto.Base64 import Data.Bits import Data.Char hmacSHA1 :: String -> String -> String hmacSHA1 key str | length key > b = fail "hmacSHA1 doesn't support large keys yet" | otherwise = encode $ sha1Raw (doxor key opad ++ sha1Raw (doxor key ipad ++ str)) where b = 64 opad = replicate b '\x5C' ipad = replicate b '\x36' doxor a = zipWith fn (a++repeat '\0') fn x y = chr (ord x `xor` ord y) happstack-util-6.0.0/src/Happstack/Crypto/DES.lhs0000644000000000000000000002614711527320401017751 0ustar0000000000000000> {-# LANGUAGE FlexibleInstances #-} > {-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-} {-- Copyright (C) 2001 Ian Lynagh DES.lhs can be used under either the BSD or GPL. http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/sha1/haskell-sha1-0.1.0/ Copyright (c) The Regents of the University of California. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --} > module Happstack.Crypto.DES (des_enc, des_dec, Message, Enc) where > import Data.Bits > import Data.Word more stuff just copied in > import Numeric -- added by alex > data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) > w64ToInteger :: Zord64 -> Integer > w64ToInteger W64{lo=l,hi=h} = toInteger l + 0x100000000 * toInteger h > integerToW64 :: Integer -> Zord64 > integerToW64 x = case x `quotRem` 0x100000000 of > (h,l) -> W64{lo=fromInteger l, hi=fromInteger h} > instance Show Zord64 where > showsPrec _ = showInt . w64ToInteger > instance Read Zord64 where > readsPrec _ s = [ (integerToW64 x,r) | (x,r) <- readDec s ] > instance Num Zord64 where > W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} > where lo' = lo_a + lo_b > hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0 > fromInteger = integerToW64 Added by alex > signum 0 = 0 > signum _ = 1 > x * y = integerToW64 $ (w64ToInteger x) * (w64ToInteger y) > instance Bits Zord64 where > W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} > where lo' = lo_a .&. lo_b > hi' = hi_a .&. hi_b > W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} > where lo' = lo_a .|. lo_b > hi' = hi_a .|. hi_b > shift w 0 = w > shift W64{lo=l,hi=h} x > | x > 63 = W64{lo=0,hi=0} > | x > 31 = W64{lo = 0, hi = shift l (x-32)} > | x > 0 = W64{lo = shift l x, hi = shift h x .|. shift l (x-32)} > shift _ _ = error "Case not defined in Bits instance for Zord64" > instance Integral Zord64 where > toInteger = w64ToInteger added by alex > quotRem numer divis = > let (d,r)= quotRem (w64ToInteger numer) (w64ToInteger divis) > in (fromInteger d,fromInteger r) > instance Real Zord64 > instance Enum Zord64 --simplifying so we don't need all the hugs decls. > type Rotation = Int > type Key = Zord64 > type Message = Zord64 > type Enc = Zord64 > -- type BitsX = [Bool] > type Bits4 = [Bool] > type Bits6 = [Bool] > type Bits32 = [Bool] > type Bits48 = [Bool] > type Bits56 = [Bool] > type Bits64 = [Bool] > instance Num [Bool] where {} > instance Bits [Bool] where > xor = zipWith (\x y -> (not x && y) || (x && not y)) > rotate bits rot = drop rot' bits ++ take rot' bits > where rot' = rot `mod` (length bits) > bitify :: Zord64 -> Bits64 > bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] > unbitify :: Bits64 -> Zord64 Added by Alex > unbitify = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 > initial_permutation :: Bits64 -> Bits64 > initial_permutation mb = map ((!!) mb) i > where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, > 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, > 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, > 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] > key_transformation :: Bits64 -> Bits56 > key_transformation kb = map ((!!) kb) i > where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, > 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, > 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, > 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] > des_enc :: Message -> Key -> Enc > des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] > des_dec :: Message -> Key -> Enc > des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] > do_des :: [Rotation] -> Message -> Key -> Enc > do_des rots m k = des_work rots (takeDrop 32 mb) kb > where kb = key_transformation $ bitify k > mb = initial_permutation $ bitify m > des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc > des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) > des_work (r:rs) mb kb = des_work rs mb' kb > where mb' = do_round r mb kb > do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) > do_round r (ml, mr) kb = (mr, m') > where kb' = get_key kb r > comp_kb = compression_permutation kb' > expa_mr = expansion_permutation mr > res = comp_kb `xor` expa_mr > res' = tail $ iterate (trans 6) ([], res) > trans n (_, b) = (take n b, drop n b) > res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, > s_box_3, s_box_4, > s_box_5, s_box_6, > s_box_7, s_box_8] res' > res_p = p_box res_s > m' = res_p `xor` ml > get_key :: Bits56 -> Rotation -> Bits56 > get_key kb r = kb' > where (kl, kr) = takeDrop 28 kb > kb' = rotateL kl r ++ rotateL kr r > compression_permutation :: Bits56 -> Bits48 > compression_permutation kb = map ((!!) kb) i > where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, > 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, > 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, > 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] > expansion_permutation :: Bits32 -> Bits48 > expansion_permutation mb = map ((!!) mb) i > where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, > 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, > 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, > 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] > s_box :: [[Word8]] -> Bits6 -> Bits4 > s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col > where row = sum $ zipWith numericise [a,f] [1, 0] > col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] > numericise = (\x y -> if x then 2^y else 0) > to_bool 0 _ = [] > to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) > s_box _ _ = error "second arg to s_box must have length 6" > s_box_1 :: Bits6 -> Bits4 > s_box_1 = s_box i > where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], > [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], > [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], > [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] > s_box_2 :: Bits6 -> Bits4 > s_box_2 = s_box i > where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], > [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], > [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], > [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] > s_box_3 :: Bits6 -> Bits4 > s_box_3 = s_box i > where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], > [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], > [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], > [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] > s_box_4 :: Bits6 -> Bits4 > s_box_4 = s_box i > where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], > [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], > [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], > [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] > s_box_5 :: Bits6 -> Bits4 > s_box_5 = s_box i > where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], > [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], > [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], > [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] > s_box_6 :: Bits6 -> Bits4 > s_box_6 = s_box i > where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], > [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], > [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], > [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] > s_box_7 :: Bits6 -> Bits4 > s_box_7 = s_box i > where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], > [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], > [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], > [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] > s_box_8 :: Bits6 -> Bits4 > s_box_8 = s_box i > where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], > [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], > [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], > [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] > p_box :: Bits32 -> Bits32 > p_box kb = map ((!!) kb) i > where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, > 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] > final_perm :: Bits64 -> Bits64 > final_perm kb = map ((!!) kb) i > where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, > 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, > 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, > 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] > takeDrop :: Int -> [a] -> ([a], [a]) > takeDrop _ [] = ([], []) > takeDrop 0 xs = ([], xs) > takeDrop n (x:xs) = (x:ys, zs) > where (ys, zs) = takeDrop (n-1) xs happstack-util-6.0.0/tests/0000755000000000000000000000000011527320401013771 5ustar0000000000000000happstack-util-6.0.0/tests/Test.hs0000644000000000000000000000120011527320401015235 0ustar0000000000000000module Main where import Happstack.Util.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout) -- |A simple driver for running the local test suite. main :: IO () main = do c <- do istty <- hIsTerminalDevice stdout if istty then runTestTT allTests else do (c,st) <- runTestText putTextToShowS allTests putStrLn (st "") return c case failures c + errors c of 0 -> return () n -> exitFailure happstack-util-6.0.0/tests/Happstack/0000755000000000000000000000000011527320401015707 5ustar0000000000000000happstack-util-6.0.0/tests/Happstack/Util/0000755000000000000000000000000011527320401016624 5ustar0000000000000000happstack-util-6.0.0/tests/Happstack/Util/Tests.hs0000644000000000000000000000247711527320401020274 0ustar0000000000000000-- |HUnit tests and QuickQuick properties for Happstack.Util.* module Happstack.Util.Tests (allTests) where import Happstack.Util.Common (split) import Happstack.Util.Testing (qctest) import Test.HUnit as HU (Test(..),(~:)) import Happstack.Util.Tests.HostAddress -- |All of the tests for happstack-util should be listed here. allTests :: Test allTests = "happstack-util tests" ~: [splitTest ,showHostAddressTest ,showHostAddressTest ] -- |turn 'splitTest_prop' into an HUnit test with a label splitTest :: Test splitTest = "splitTest" ~: qctest splitTest_prop -- |a QuickCheck property which tests 'split' splitTest_prop :: Bool -> [Bool] -> Bool splitTest_prop elem list = let (left1, right1) = split (elem ==) list (left2, right2) = break (elem ==) list right2' = case right2 of (r:rs) | r == elem -> rs _ -> right2 in (left1 == left2) && (right1 == right2') -- |test showHostAddress against inet_ntoa to ensure that the same results occur showHostAddressTest :: Test showHostAddressTest = "showHostAddressTest" ~: qctest propShowHostAddress -- |test showHostAddress6 against getNameInfo to ensure that the same results occur showHostAddress6Test :: Test showHostAddress6Test = "showHostAddress6Test" ~: qctest propShowHostAddress6 happstack-util-6.0.0/tests/Happstack/Util/Tests/0000755000000000000000000000000011527320401017726 5ustar0000000000000000happstack-util-6.0.0/tests/Happstack/Util/Tests/HostAddress.hs0000644000000000000000000000200311527320401022500 0ustar0000000000000000{-# LANGUAGE CPP #-} module Happstack.Util.Tests.HostAddress (propShowHostAddress, propShowHostAddress6) where import Happstack.Util.HostAddress import System.IO.Unsafe import Network.Socket (inet_ntoa, getNameInfo, NameInfoFlag(..), SockAddr(..), aNY_PORT) import Data.Word (Word32) import System.Random import Test.QuickCheck #if MIN_VERSION_QuickCheck(2,1,2) #else instance Arbitrary Word32 where arbitrary = choose (minBound, maxBound) instance Random Word32 where randomR (a,b) g = (fromInteger i,g) where (i,_) = randomR (toInteger a, toInteger b) g random = randomR (minBound,maxBound) #endif propShowHostAddress :: HostAddress -> Bool propShowHostAddress a = new == old where old = (unsafePerformIO . inet_ntoa) a new = showHostAddress a propShowHostAddress6 :: HostAddress6 -> Bool propShowHostAddress6 a = new == old where (Just old, _) = (unsafePerformIO . getNameInfo [NI_NUMERICHOST] True False) $ SockAddrInet6 aNY_PORT 0 a 0 new = showHostAddress6 a