Browse Source

Hfmt.

tags/0.1.0.0
Thomas Kerber 1 year ago
parent
commit
ee7850379f
Signed by: Thomas Kerber <t.kerber@ed.ac.uk> GPG Key ID: 8489B911F9ED617B
9 changed files with 347 additions and 197 deletions
  1. +1
    -0
      .gitignore
  2. +21
    -13
      src/Yggdrasil/Adversarial.hs
  3. +48
    -29
      src/Yggdrasil/Distribution.hs
  4. +75
    -49
      src/Yggdrasil/ExecutionModel.hs
  5. +80
    -53
      src/Yggdrasil/Functionalities.hs
  6. +65
    -0
      stack.yaml
  7. +21
    -19
      tests/ExecTests.hs
  8. +31
    -29
      tests/FunctTests.hs
  9. +5
    -5
      tests/Spec.hs

+ 1
- 0
.gitignore View File

@@ -1 +1,2 @@
/dist
/.stack-work

+ 21
- 13
src/Yggdrasil/Adversarial.hs View File

@@ -1,12 +1,17 @@
{-# LANGUAGE TupleSections #-}

module Yggdrasil.Adversarial (
WithAdversary, Adversary, createAdversarial, noAdversary, dummyAdversary
) where
module Yggdrasil.Adversarial
( WithAdversary
, Adversary
, createAdversarial
, noAdversary
, dummyAdversary
) where

import Data.Dynamic (Typeable)
import Yggdrasil.ExecutionModel
(Action, Functionality(Functionality), create, interface')
import Data.Dynamic (Typeable)
import Yggdrasil.ExecutionModel (Action,
Functionality (Functionality),
create, interface')

type WithAdversary b c = Action (Maybe b) -> c

@@ -14,8 +19,8 @@ type Adversary s a b = Functionality s (Action (Maybe a), b)

-- | An adversary that just returns 'Nothing'.
noAdversary :: Adversary () a ()
noAdversary = Functionality ()
((,()) <$> interface' (\_ -> return ((), Nothing)))
noAdversary =
Functionality () ((, ()) <$> interface' (\_ -> return ((), Nothing)))

-- | An adversary that simply forwards a reference to the environment
dummyAdversary :: Action (Maybe b) -> Adversary () b ()
@@ -23,9 +28,12 @@ dummyAdversary ref = Functionality () (return (ref, ()))

-- | Given an adversary, and a functionality that requires one, link the two
-- and return their respective handles.
createAdversarial :: (Typeable s, Typeable s') =>
Adversary s a c -> WithAdversary a (Functionality s' b) -> Action (b, c)
createAdversarial ::
(Typeable s, Typeable s')
=> Adversary s a c
-> WithAdversary a (Functionality s' b)
-> Action (b, c)
createAdversarial adv fnc = do
(advFnc, advEnv) <- create adv
fncEnv <- create $ fnc advFnc
return (fncEnv, advEnv)
(advFnc, advEnv) <- create adv
fncEnv <- create $ fnc advFnc
return (fncEnv, advEnv)

+ 48
- 29
src/Yggdrasil/Distribution.hs View File

@@ -2,38 +2,49 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Yggdrasil.Distribution (
Distribution, Sampler, sample, sample', coin, uniform
) where
module Yggdrasil.Distribution
( Distribution
, Sampler
, sample
, sample'
, coin
, uniform
) where

import Control.Monad (ap)
import Crypto.Random (SystemDRG, randomBytesGenerate)
import Data.Bits ((.&.))
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Crypto.Random (SystemDRG, randomBytesGenerate)
import Data.Bits ((.&.))
import qualified Data.ByteArray as B
import Data.Maybe (fromJust)

newtype Distribution b = Distribution (forall s. Sampler s => s -> (b, s))
newtype Distribution b =
Distribution (forall s. Sampler s =>
s -> (b, s))

instance Functor Distribution where
fmap f x = pure f <*> x
fmap f x = pure f <*> x

instance Applicative Distribution where
pure x = Distribution (x,)
(<*>) = ap
pure x = Distribution (x, )
(<*>) = ap

instance Monad Distribution where
a >>= b = Distribution (\s -> let
(a', s') = sample s a
(b', s'') = sample s' (b a')
in (b', s''))
a >>= b =
Distribution
(\s ->
let (a', s') = sample s a
(b', s'') = sample s' (b a')
in (b', s''))

class Sampler s where
sampleCoin :: s -> (Bool, s)
sampleCoin :: s -> (Bool, s)

instance Sampler SystemDRG where
sampleCoin s = (b .&. 1 == 1, s')
where
(ba :: B.Bytes, s') = randomBytesGenerate 1 s
sampleCoin s = (b .&. 1 == 1, s')
where
(ba :: B.Bytes, s') = randomBytesGenerate 1 s
-- fromJust is safe, as the array is not empty.
(b, _) = fromJust $ B.uncons ba
(b, _) = fromJust $ B.uncons ba

sample :: Sampler s => s -> Distribution b -> (b, s)
sample s (Distribution f) = f s
@@ -46,19 +57,27 @@ coin = Distribution sampleCoin

uniform :: [a] -> Distribution a
uniform xs = do
let l = length xs
let lg = ilog2 l
n <- samplen lg
if n > l then uniform xs else return (xs !! n)
let l = length xs
let lg = ilog2 l
n <- samplen lg
if n > l
then uniform xs
else return (xs !! n)
where
ilog2 :: Int -> Int
ilog2 1 = 0
ilog2 n | n > 1 = ilog2 (n `div` 2) + 1
ilog2 n
| n > 1 = ilog2 (n `div` 2) + 1
ilog2 _ = error "attempted non-postive logarithm"
samplen :: Int -> Distribution Int
samplen 0 = return 0
samplen lg | lg > 0 = do
n' <- samplen (lg-1)
c <- coin
return $ (n' * 2) + if c then 1 else 0
samplen lg
| lg > 0 = do
n' <- samplen (lg - 1)
c <- coin
return $
(n' * 2) +
if c
then 1
else 0
samplen _ = error "attempted to sample negative logarithm"

+ 75
- 49
src/Yggdrasil/ExecutionModel.hs View File

@@ -3,31 +3,48 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Yggdrasil.ExecutionModel (
Operation, Ref, Action, Functionality(..), external, weaken, abort,
interface, interface', self, doSample, create, run
) where

import Control.Monad (ap)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)
import Yggdrasil.Distribution (Distribution)

newtype World = World [Dynamic]
module Yggdrasil.ExecutionModel
( Operation
, Ref
, Action
, Functionality(..)
, external
, weaken
, abort
, interface
, interface'
, self
, doSample
, create
, run
) where

import Control.Monad (ap)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import Data.Dynamic (Dynamic, Typeable, fromDynamic,
toDyn)
import Yggdrasil.Distribution (Distribution)

newtype World =
World [Dynamic]

-- | An operation is a stateful function of @('Ref, a) -> 'Action' b@ over
-- the state @s@.
type Operation s a b = (s, Ref, a) -> Action (s, b)

data Functionality s b = Functionality s (Action b)
data Functionality s b =
Functionality s
(Action b)

data SendRef a b where
SendRef :: Typeable s => Int -> Operation s a b -> SendRef a b
SendRef :: Typeable s => Int -> Operation s a b -> SendRef a b

-- | A weakened reference, that allows comparing entities for equality, but
-- nothing else.
newtype Ref = Ref Int deriving Eq
newtype Ref =
Ref Int
deriving (Eq)

-- | A special reference indicating that something is external of the world.
-- This does not have a corresponding strong reference.
@@ -37,15 +54,15 @@ external = Ref (-1)
weaken :: SendRef a b -> Ref
weaken (SendRef idx _) = Ref idx

strengthen :: Typeable s =>
World -> Ref -> Operation s a b -> Maybe (SendRef a b)
strengthen ::
Typeable s => World -> Ref -> Operation s a b -> Maybe (SendRef a b)
strengthen (World []) _ _ = Nothing
strengthen (World (x:_)) (Ref 0) (f :: Operation s a b) = do
_ :: s <- fromDynamic x
return $ SendRef 0 f
_ :: s <- fromDynamic x
return $ SendRef 0 f
strengthen (World (_:xs)) wref f = do
(SendRef i f') <- strengthen (World xs) wref f
return $ SendRef (i+1) f'
(SendRef i f') <- strengthen (World xs) wref f
return $ SendRef (i + 1) f'

new :: Typeable s => World -> s -> (World, Ref)
new (World xs) s = (World (xs ++ [toDyn s]), Ref (length xs))
@@ -53,28 +70,31 @@ new (World xs) s = (World (xs ++ [toDyn s]), Ref (length xs))
safeIdx :: [a] -> Int -> Maybe a
safeIdx [] _ = Nothing
safeIdx (x:_) 0 = Just x
safeIdx _ i | i < 0 = Nothing
safeIdx (_:xs) i = safeIdx xs (i-1)
safeIdx _ i
| i < 0 = Nothing
safeIdx (_:xs) i = safeIdx xs (i - 1)

safeWriteIdx :: [a] -> Int -> a -> Maybe [a]
safeWriteIdx [] _ _ = Nothing
safeWriteIdx (_:xs) 0 x' = Just (x':xs)
safeWriteIdx _ i _ | i < 0 = Nothing
safeWriteIdx (x:xs) i x' = (:) x <$> safeWriteIdx xs (i-1) x'
safeWriteIdx (_:xs) 0 x' = Just (x' : xs)
safeWriteIdx _ i _
| i < 0 = Nothing
safeWriteIdx (x:xs) i x' = (:) x <$> safeWriteIdx xs (i - 1) x'

data Action b where
Abort :: Action b
StrengthenSelf :: Typeable s => Operation s a b -> Action (a -> Action b)
Self :: Action Ref
Sample :: Distribution b -> Action b
Send :: SendRef a b -> a -> Action b
Create :: Typeable s => Functionality s b -> Action b
Compose :: Action c -> (c -> Action b) -> Action b
Abort :: Action b
StrengthenSelf :: Typeable s => Operation s a b -> Action (a -> Action b)
Self :: Action Ref
Sample :: Distribution b -> Action b
Send :: SendRef a b -> a -> Action b
Create :: Typeable s => Functionality s b -> Action b
Compose :: Action c -> (c -> Action b) -> Action b

-- Export visible constructors as functions.
-- | Aborts the current execution.
abort :: Action b
abort = Abort

-- | Attempts to add a new operation on ourselves.
-- This action will fail (effectively aborting) if our state is not of type
-- 's'.
@@ -83,24 +103,29 @@ interface = StrengthenSelf

interface' :: Typeable s => Operation s () b -> Action (Action b)
interface' op = (\f -> f ()) <$> interface op

-- | Obtain a weak reference on ourselves.
self :: Action Ref
self = Self

-- | Sample from a distribution
doSample :: Distribution b -> Action b
doSample = Sample

-- | Creates a new autonomous party, with a given initial state, and a given
-- program.
create :: Typeable s => Functionality s b -> Action b
create = Create

instance Functor Action where
fmap f x = pure f <*> x
fmap f x = pure f <*> x

instance Applicative Action where
pure = Sample . pure
(<*>) = ap
pure = Sample . pure
(<*>) = ap

instance Monad Action where
a >>= b = Compose a b
a >>= b = Compose a b

-- | Execute a top-level action in the Yggdrasil execution model.
run :: Action b -> Distribution (Maybe b)
@@ -108,20 +133,21 @@ run a = runMaybeT $ snd <$> run' (World []) external a

run' :: World -> Ref -> Action b -> MaybeT Distribution (World, b)
run' _ _ Abort = MaybeT $ return Nothing
run' wld slf (StrengthenSelf f) = MaybeT $ return $
(wld,) . Send <$> strengthen wld slf f
run' wld slf (StrengthenSelf f) =
MaybeT $ return $ (wld, ) . Send <$> strengthen wld slf f
run' wld slf Self = MaybeT $ return $ Just (wld, slf)
run' wld _ (Sample d) = lift $ (wld,) <$> d
run' wld _ (Sample d) = lift $ (wld, ) <$> d
run' (World xs) from (Send to@(SendRef idx func) m) = do
dyns <- MaybeT $ return $ safeIdx xs idx
st <- MaybeT $ return $ fromDynamic dyns
let action = func (st, from, m)
(World xs', (st', y)) <- run' (World xs) (weaken to) action
xs'' <- MaybeT $ return $ safeWriteIdx xs' idx (toDyn st')
return (World xs'', y)
dyns <- MaybeT $ return $ safeIdx xs idx
st <- MaybeT $ return $ fromDynamic dyns
let action = func (st, from, m)
(World xs', (st', y)) <- run' (World xs) (weaken to) action
xs'' <- MaybeT $ return $ safeWriteIdx xs' idx (toDyn st')
return (World xs'', y)
-- Note: This could cause a re-entrancy style bug!
run' wld _ (Create (Functionality st a)) =
let (wld', from') = new wld st in run' wld' from' a
let (wld', from') = new wld st
in run' wld' from' a
run' wld from (Compose a f) = do
(wld', b) <- run' wld from a
run' wld' from (f b)
(wld', b) <- run' wld from a
run' wld' from (f b)

+ 80
- 53
src/Yggdrasil/Functionalities.hs View File

@@ -1,81 +1,108 @@
module Yggdrasil.Functionalities
( ROState
, SigState
, SignatureInterface(..)
, commonRandomString
, randomOracle
, signature
, robustSignature
) where

module Yggdrasil.Functionalities (
ROState, SigState, SignatureInterface(..), commonRandomString,
randomOracle, signature, robustSignature
) where

import Data.Dynamic (Typeable)
import Yggdrasil.Adversarial (WithAdversary)
import Yggdrasil.ExecutionModel (
Action, Functionality(Functionality), Ref, Operation, abort, doSample,
interface, interface')
import Yggdrasil.Distribution (Distribution, coin)
import Data.Dynamic (Typeable)
import Yggdrasil.Adversarial (WithAdversary)
import Yggdrasil.Distribution (Distribution, coin)
import Yggdrasil.ExecutionModel (Action,
Functionality (Functionality),
Operation, Ref, abort, doSample,
interface, interface')

crsOp :: Distribution b -> Operation (Maybe b) () b
crsOp _ (Just x, _, ()) = return (Just x, x)
crsOp _ (Just x, _, ()) = return (Just x, x)
crsOp d (Nothing, _, ()) = (\x -> (Just x, x)) <$> doSample d
commonRandomString :: Typeable b =>
Distribution b -> Functionality (Maybe b) (Action b)

commonRandomString ::
Typeable b => Distribution b -> Functionality (Maybe b) (Action b)
commonRandomString d = Functionality Nothing (interface' (crsOp d))

type ROState a b = [(a, b)]

roLookup :: Eq a => ROState a b -> a -> Maybe b
roLookup [] _ = Nothing
roLookup ((x, y):_) x' | x == x' = Just y
roLookup ((x, y):_) x'
| x == x' = Just y
roLookup (_:xs) x = roLookup xs x

roOp :: Eq a => Distribution b -> Operation (ROState a b) a b
roOp d (xs, _, x') = case roLookup xs x' of
roOp d (xs, _, x') =
case roLookup xs x' of
Just y -> return (xs, y)
Nothing -> do
y <- doSample d
return ((x', y):xs, y)
randomOracle :: (Eq a, Typeable a, Typeable b) =>
Distribution b -> Functionality (ROState a b) (a -> Action b)
y <- doSample d
return ((x', y) : xs, y)

randomOracle ::
(Eq a, Typeable a, Typeable b)
=> Distribution b
-> Functionality (ROState a b) (a -> Action b)
randomOracle d = Functionality [] (interface $ roOp d)

-- TODO: Don't abort with bad adversaries? Would probably need a specialised s
-- though.
type SigState m s = [(m, s, Ref)]

data SignatureInterface m s = SignatureInterface
{ sign :: m -> Action s
, verify :: (m, s, Ref) -> Action Bool
}
{ sign :: m -> Action s
, verify :: (m, s, Ref) -> Action Bool
}

signOp :: Eq s => ((m, Ref) -> Action s) -> Operation (SigState m s) m s
signOp adv (st, from, m) = do
sig <- adv (m, from)
if sig `elem` map (\(_, s, _) -> s) st
then abort
else return ((m, sig, from):st, sig)
sig <- adv (m, from)
if sig `elem` map (\(_, s, _) -> s) st
then abort
else return ((m, sig, from) : st, sig)

verifyOp :: (Eq m, Eq s) => Operation (SigState m s) (m, s, Ref) Bool
verifyOp (st, _, s) = return (st, s `elem` st)
signature :: (Eq m, Eq s, Typeable m, Typeable s) =>
WithAdversary ((m, Ref) -> Action s)
(Functionality (SigState m s) (SignatureInterface m s))
signature adv = Functionality [] (do
adv' <- adv
adv'' <- maybe abort return adv'

signature ::
(Eq m, Eq s, Typeable m, Typeable s)
=> WithAdversary ((m, Ref) -> Action s) (Functionality (SigState m s) (SignatureInterface m s))
signature adv =
Functionality
[]
(do adv' <- adv
adv'' <- maybe abort return adv'
--adv'' <- fromMaybe abort (return <$> adv')
sign' <- interface $ signOp adv''
verify' <- interface verifyOp
return $ SignatureInterface sign' verify')
sign' <- interface $ signOp adv''
verify' <- interface verifyOp
return $ SignatureInterface sign' verify')

robustSignOp :: Maybe ((m, Ref) -> Action [Bool]) -> Int ->
Operation (SigState m [Bool]) m [Bool]
robustSignOp ::
Maybe ((m, Ref) -> Action [Bool])
-> Int
-> Operation (SigState m [Bool]) m [Bool]
robustSignOp (Just adv) secparam (st, from, m) = do
sig <- adv (m, from)
sig' <- if sig `elem` map (\(_, s, _) -> s) st
then forceSample secparam
else return sig
return ((m, sig', from):st, sig')
sig <- adv (m, from)
sig' <-
if sig `elem` map (\(_, s, _) -> s) st
then forceSample secparam
else return sig
return ((m, sig', from) : st, sig')
robustSignOp Nothing secparam (st, from, m) =
(\sig -> ((m, sig, from):st, sig)) <$> forceSample secparam
(\sig -> ((m, sig, from) : st, sig)) <$> forceSample secparam

forceSample :: Int -> Action [Bool]
forceSample secparam = sequence [doSample coin | _ <- [0..secparam]]
robustSignature :: (Eq m, Typeable m) =>
Int -> WithAdversary ((m, Ref) -> Action [Bool])
(Functionality (SigState m [Bool]) (SignatureInterface m [Bool]))
robustSignature secparam adv = Functionality [] (do
adv' <- adv
sign' <- interface $ robustSignOp adv' secparam
verify' <- interface verifyOp
return $ SignatureInterface sign' verify')
forceSample secparam = sequence [doSample coin | _ <- [0 .. secparam]]

robustSignature ::
(Eq m, Typeable m)
=> Int
-> WithAdversary ((m, Ref) -> Action [Bool]) (Functionality (SigState m [Bool]) (SignatureInterface m [Bool]))
robustSignature secparam adv =
Functionality
[]
(do adv' <- adv
sign' <- interface $ robustSignOp adv' secparam
verify' <- interface verifyOp
return $ SignatureInterface sign' verify')

+ 65
- 0
stack.yaml View File

@@ -0,0 +1,65 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/

# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-12.9

# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field.
# (e.g., acme-missiles-0.3)
# extra-deps: []

# Override default flag values for local packages and extra-deps
# flags: {}

# Extra package databases containing global packages
# extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.7"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

+ 21
- 19
tests/ExecTests.hs View File

@@ -1,13 +1,16 @@
{-# LANGUAGE ScopedTypeVariables #-}

module ExecTests (spec) where
module ExecTests
( spec
) where

import Crypto.Random (getSystemDRG)
import Data.Maybe (fromJust)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.QuickCheck (prop)
import Yggdrasil.ExecutionModel (Action, doSample, external, run, self)
import Yggdrasil.Distribution (uniform, sample')
import Crypto.Random (getSystemDRG)
import Data.Maybe (fromJust)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.QuickCheck (prop)
import Yggdrasil.Distribution (sample', uniform)
import Yggdrasil.ExecutionModel (Action, doSample, external, run,
self)

inSampleRange :: Int -> Bool
inSampleRange x = x > 4700 && x < 5300
@@ -18,18 +21,17 @@ sampleTest = sampleTest' 10000
sampleTest' :: Int -> Action Int
sampleTest' 0 = return 0
sampleTest' n = do
x <- sampleTest' (n-1)
b <- doSample (uniform [0, 1])
return $ x + b
x <- sampleTest' (n - 1)
b <- doSample (uniform [0, 1])
return $ x + b

spec :: IO Spec
spec = do
rnd <- getSystemDRG
return $ describe "action" $ do
prop "obeys return" $ \(x::String) ->
sample' rnd (run (return x)) == Just x
it "is exteral" $
sample' rnd (run self) == Just external `shouldBe` True
it "samples evenly" $
inSampleRange (fromJust $ sample' rnd (run sampleTest))
`shouldBe` True
rnd <- getSystemDRG
return $
describe "action" $ do
prop "obeys return" $ \(x :: String) ->
sample' rnd (run (return x)) == Just x
it "is exteral" $ sample' rnd (run self) == Just external `shouldBe` True
it "samples evenly" $
inSampleRange (fromJust $ sample' rnd (run sampleTest)) `shouldBe` True

+ 31
- 29
tests/FunctTests.hs View File

@@ -1,44 +1,46 @@
{-# LANGUAGE ScopedTypeVariables #-}

module FunctTests (spec) where
module FunctTests
( spec
) where

import Crypto.Random (getSystemDRG)
import Test.Hspec (Spec, describe, it, shouldBe)
import Yggdrasil.ExecutionModel (Action, create, run)
import Yggdrasil.Distribution (uniform, sample')
import Yggdrasil.Functionalities (commonRandomString, randomOracle)
import Crypto.Random (getSystemDRG)
import Test.Hspec (Spec, describe, it, shouldBe)
import Yggdrasil.Distribution (sample', uniform)
import Yggdrasil.ExecutionModel (Action, create, run)
import Yggdrasil.Functionalities (commonRandomString, randomOracle)

crsSameTest :: Action Bool
crsSameTest = do
crsHandle <- create $ commonRandomString (uniform [0..10000::Int])
fst' <- crsHandle
snd' <- crsHandle
return (fst' == snd')
crsHandle <- create $ commonRandomString (uniform [0 .. 10000 :: Int])
fst' <- crsHandle
snd' <- crsHandle
return (fst' == snd')

roSameTest :: Action Bool
roSameTest = do
roHandle :: (Int -> Action Int) <- create $
randomOracle (uniform [0..1000::Int])
fst' <- roHandle 1
snd' <- roHandle 1
return (fst' == snd')
roHandle :: (Int -> Action Int) <-
create $ randomOracle (uniform [0 .. 1000 :: Int])
fst' <- roHandle 1
snd' <- roHandle 1
return (fst' == snd')

roAllEqual :: Action Bool
roAllEqual = do
roHandle :: (Int -> Action Int) <-
create $ randomOracle (uniform [0..1000::Int])
xs <- sequence [roHandle i | i <- [1..1000]]
return $ all (== head xs) (tail xs)
roHandle :: (Int -> Action Int) <-
create $ randomOracle (uniform [0 .. 1000 :: Int])
xs <- sequence [roHandle i | i <- [1 .. 1000]]
return $ all (== head xs) (tail xs)

spec :: IO Spec
spec = do
rnd <- getSystemDRG
return $ do
describe "common random string" $
it "returns the same value" $
sample' rnd (run crsSameTest) `shouldBe` Just True
describe "random oracle" $ do
it "returns the same for the same query" $
sample' rnd (run roSameTest) `shouldBe` Just True
it "is random with different queries" $
sample' rnd (run roAllEqual) `shouldBe` Just False
rnd <- getSystemDRG
return $ do
describe "common random string" $
it "returns the same value" $
sample' rnd (run crsSameTest) `shouldBe` Just True
describe "random oracle" $ do
it "returns the same for the same query" $
sample' rnd (run roSameTest) `shouldBe` Just True
it "is random with different queries" $
sample' rnd (run roAllEqual) `shouldBe` Just False

+ 5
- 5
tests/Spec.hs View File

@@ -1,11 +1,11 @@
import Test.Hspec (hspec)
import Test.Hspec (hspec)

import qualified ExecTests
import qualified FunctTests

main :: IO ()
main = do
execTests <- ExecTests.spec
functTests <- FunctTests.spec
hspec execTests
hspec functTests
execTests <- ExecTests.spec
functTests <- FunctTests.spec
hspec execTests
hspec functTests

Loading…
Cancel
Save