{-# 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
newtype Credential = Credential Text
deriving (Eq,Show,Generic,NFData)
credentialAlphabet :: [Char]
credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
tokenBase :: Int
tokenBase = List.length credentialAlphabet
tokenLength ::Int
tokenLength = 14
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
return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
where
charOfDigit = (credentialAlphabet List.!!)
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
data CredentialError
= CredentialError_BadChar Char.Char
| CredentialError_Checksum
| CredentialError_Length
deriving (Eq,Show,Generic,NFData)
newtype UUID = UUID Text
deriving (Eq,Ord,Show,Generic,NFData)
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 = E
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 = G
publicKey :: SubGroup q => SecretKey q -> PublicKey q
publicKey = (groupGen ^)