summaryrefslogtreecommitdiff
path: root/src/Voting/Protocol/Credential.hs
blob: 39ac87b20c526fc27207c527ae16db9f5dc73ef4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Voting.Protocol.Credential where

import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), replicateM)
import Data.Bits
import Data.Bool
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (maybe)
import Data.Ord (Ord(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Prelude (Integral(..), fromIntegral, div)
import Text.Show (Show)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Crypto.KDF.PBKDF2 as Crypto
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified System.Random as Random

import Voting.Protocol.Arithmetic

-- * Type 'Credential'
-- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters
-- from a base alphabet of (@'tokenBase' '==' 58)@ characters:
-- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
-- (beware the absence of "0", \"O", \"I", and "l").
-- The last character is a checksum.
-- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.
newtype Credential = Credential Text
 deriving (Eq,Show,Generic,NFData)

credentialAlphabet :: [Char] -- TODO: make this an array
credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
tokenBase :: Int
tokenBase = List.length credentialAlphabet
tokenLength ::Int
tokenLength = 14

-- | @'randomCredential'@ generates a random 'Credential'.
randomCredential :: Monad m => Random.RandomGen r => S.StateT r m Credential
randomCredential = do
	rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
	let (tot, cs) = List.foldl' (\(acc,ds) d ->
			( acc * tokenBase + d
			, charOfDigit d : ds )
		 ) (zero::Int, []) rs
	let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
	return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
	where
	charOfDigit = (credentialAlphabet List.!!)

-- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
-- from raw 'Text'.
readCredential :: Text -> Either CredentialError Credential
readCredential s
 | Text.length s /= tokenLength + 1 = Left CredentialError_Length
 | otherwise = do
	tot <- Text.foldl'
	 (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
	 (Right (zero::Int))
	 (Text.init s)
	checksum <- digitOfChar (Text.last s)
	if (tot + checksum) `mod` 53 == 0
	then Right (Credential s)
	else Left CredentialError_Checksum
	where
	digitOfChar c =
		maybe (Left $ CredentialError_BadChar c) Right $
		List.elemIndex c credentialAlphabet

-- ** Type 'CredentialError'
data CredentialError
 =   CredentialError_BadChar Char.Char
 |   CredentialError_Checksum
 |   CredentialError_Length
 deriving (Eq,Show,Generic,NFData)

-- ** Type 'UUID'
newtype UUID = UUID Text
 deriving (Eq,Ord,Show,Generic,NFData)

-- | @'randomUUID'@ generates a random 'UUID'.
randomUUID ::
 Monad m =>
 Random.RandomGen r =>
 S.StateT r m UUID
randomUUID = do
	rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
	return $ UUID $ Text.pack $ charOfDigit <$> rs
	where
	charOfDigit = (credentialAlphabet List.!!)

-- ** Type 'SecretKey'
type SecretKey = E

randomSecretKey :: Monad m => RandomGen r => SubGroup q => S.StateT r m (SecretKey q)
randomSecretKey = random

-- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
-- derived from given 'uuid' and 'cred'
-- using 'Crypto.fastPBKDF2_SHA256'.
credentialSecretKey :: SubGroup q => UUID -> Credential -> SecretKey q
credentialSecretKey (UUID uuid) (Credential cred) =
	fromNatural $ BS.foldl'
	 (\acc b -> acc`shiftL`3 + fromIntegral b)
	 (0::Natural)
	 (ByteArray.convert deriv)
	where
	deriv :: BS.ByteString
	deriv =
		Crypto.fastPBKDF2_SHA256
		 Crypto.Parameters
		 { Crypto.iterCounts   = 1000
		 , Crypto.outputLength = 256 `div` 8
		 }
		 (Text.encodeUtf8 cred)
		 (Text.encodeUtf8 uuid)

-- ** Type 'PublicKey'
type PublicKey = G

-- | @('publicKey' secKey)@ returns the 'PublicKey'
-- derived from given 'SecretKey'.
publicKey :: SubGroup q => SecretKey q -> PublicKey q
publicKey = (groupGen ^)