{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
module Voting.Protocol.Credential where

import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), forM_, replicateM)
import Data.Bool
import Data.Char (Char)
import Data.Either (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.Reflection (Reifies(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Prelude (Integral(..), fromIntegral)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified System.Random as Random

import Voting.Protocol.Arithmetic
import Voting.Protocol.Cryptography

-- * Class 'Key'
class Key crypto where
	-- | Type of cryptography, eg. "FFC".
	cryptoType :: crypto -> Text
	-- | Name of the cryptographic paramaters, eg. "Belenios".
	cryptoName :: crypto -> Text
	-- | Generate a random 'SecretKey'.
	randomSecretKey ::
	 Reifies c crypto =>
	 Monad m => Random.RandomGen r =>
	 S.StateT r m (SecretKey crypto c)
	-- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
	-- derived from given 'uuid' and 'cred'
	-- using 'Crypto.fastPBKDF2_SHA256'.
	credentialSecretKey ::
	 Reifies c crypto =>
	 UUID -> Credential -> SecretKey crypto c
	-- | @('publicKey' secKey)@ returns the 'PublicKey'
	-- derived from given 'SecretKey' @secKey@.
	publicKey ::
	 Reifies c crypto =>
	 SecretKey crypto c ->
	 PublicKey crypto c

-- * 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 (Credential -> Credential -> Bool
(Credential -> Credential -> Bool)
-> (Credential -> Credential -> Bool) -> Eq Credential
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Credential -> Credential -> Bool
$c/= :: Credential -> Credential -> Bool
== :: Credential -> Credential -> Bool
$c== :: Credential -> Credential -> Bool
Eq,Int -> Credential -> ShowS
[Credential] -> ShowS
Credential -> String
(Int -> Credential -> ShowS)
-> (Credential -> String)
-> ([Credential] -> ShowS)
-> Show Credential
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Credential] -> ShowS
$cshowList :: [Credential] -> ShowS
show :: Credential -> String
$cshow :: Credential -> String
showsPrec :: Int -> Credential -> ShowS
$cshowsPrec :: Int -> Credential -> ShowS
Show,(forall x. Credential -> Rep Credential x)
-> (forall x. Rep Credential x -> Credential) -> Generic Credential
forall x. Rep Credential x -> Credential
forall x. Credential -> Rep Credential x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Credential x -> Credential
$cfrom :: forall x. Credential -> Rep Credential x
Generic)
 deriving newtype Credential -> ()
(Credential -> ()) -> NFData Credential
forall a. (a -> ()) -> NFData a
rnf :: Credential -> ()
$crnf :: Credential -> ()
NFData
 deriving newtype [Credential] -> Encoding
[Credential] -> Value
Credential -> Encoding
Credential -> Value
(Credential -> Value)
-> (Credential -> Encoding)
-> ([Credential] -> Value)
-> ([Credential] -> Encoding)
-> ToJSON Credential
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Credential] -> Encoding
$ctoEncodingList :: [Credential] -> Encoding
toJSONList :: [Credential] -> Value
$ctoJSONList :: [Credential] -> Value
toEncoding :: Credential -> Encoding
$ctoEncoding :: Credential -> Encoding
toJSON :: Credential -> Value
$ctoJSON :: Credential -> Value
JSON.ToJSON
instance JSON.FromJSON Credential where
	parseJSON :: Value -> Parser Credential
parseJSON json :: Value
json@(JSON.String Text
s) =
		(ErrorToken -> Parser Credential)
-> (Credential -> Parser Credential)
-> Either ErrorToken Credential
-> Parser Credential
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ErrorToken
err -> String -> Value -> Parser Credential
forall a. String -> Value -> Parser a
JSON.typeMismatch (String
"Credential: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>ErrorToken -> String
forall a. Show a => a -> String
show ErrorToken
err) Value
json) Credential -> Parser Credential
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorToken Credential -> Parser Credential)
-> Either ErrorToken Credential -> Parser Credential
forall a b. (a -> b) -> a -> b
$
		Text -> Either ErrorToken Credential
readCredential Text
s
	parseJSON Value
json = String -> Value -> Parser Credential
forall a. String -> Value -> Parser a
JSON.typeMismatch String
"Credential" Value
json

credentialAlphabet :: [Char] -- TODO: make this an array
credentialAlphabet :: String
credentialAlphabet = String
"123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
tokenBase :: Int
tokenBase :: Int
tokenBase = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length String
credentialAlphabet
tokenLength ::Int
tokenLength :: Int
tokenLength = Int
14

-- | @'randomCredential'@ generates a random 'Credential'.
randomCredential :: Monad m => Random.RandomGen r => S.StateT r m Credential
randomCredential :: StateT r m Credential
randomCredential = do
	[Int]
rs <- Int -> StateT r m Int -> StateT r m [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
tokenLength (Int -> StateT r m Int
forall (m :: * -> *) r i.
(Monad m, RandomGen r, Random i, Ring i) =>
i -> StateT r m i
randomR (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tokenBase))
	let (Int
tot, String
cs) = ((Int, String) -> Int -> (Int, String))
-> (Int, String) -> [Int] -> (Int, String)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\(Int
acc,String
ds) Int
d ->
			( Int
acc Int -> Int -> Int
forall a. Semiring a => a -> a -> a
* Int
tokenBase Int -> Int -> Int
forall a. Additive a => a -> a -> a
+ Int
d
			, Int -> Char
charOfDigit Int
d Char -> ShowS
forall a. a -> [a] -> [a]
: String
ds )
		 ) (Int
forall a. Additive a => a
zero::Int, []) [Int]
rs
	let checksum :: Int
checksum = (Int -> Int
forall a. Ring a => a -> a
negate Int
tot Int -> Int -> Int
forall a. Additive a => a -> a -> a
+ Int
53) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
53 -- NOTE: why 53 and not 'tokenBase' ?
	Credential -> StateT r m Credential
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential -> StateT r m Credential)
-> Credential -> StateT r m Credential
forall a b. (a -> b) -> a -> b
$ Text -> Credential
Credential (Text -> Credential) -> Text -> Credential
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.reverse (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (Int -> Char
charOfDigit Int
checksumChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs)
	where
	charOfDigit :: Int -> Char
charOfDigit = (String
credentialAlphabet String -> Int -> Char
forall a. [a] -> Int -> a
List.!!)

-- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
-- from raw 'Text'.
readCredential :: Text -> Either ErrorToken Credential
readCredential :: Text -> Either ErrorToken Credential
readCredential Text
s
 | Text -> Int
Text.length Text
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
tokenLength Int -> Int -> Int
forall a. Additive a => a -> a -> a
+ Int
1 = ErrorToken -> Either ErrorToken Credential
forall a b. a -> Either a b
Left ErrorToken
ErrorToken_Length
 | Bool
otherwise = do
	Int
tot <- (Either ErrorToken Int -> Char -> Either ErrorToken Int)
-> Either ErrorToken Int -> Text -> Either ErrorToken Int
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl'
	 (\Either ErrorToken Int
acc Char
c -> Either ErrorToken Int
acc Either ErrorToken Int
-> (Int -> Either ErrorToken Int) -> Either ErrorToken Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
a -> ((Int
a Int -> Int -> Int
forall a. Semiring a => a -> a -> a
* Int
tokenBase) Int -> Int -> Int
forall a. Additive a => a -> a -> a
+) (Int -> Int) -> Either ErrorToken Int -> Either ErrorToken Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Either ErrorToken Int
digitOfChar Char
c)
	 (Int -> Either ErrorToken Int
forall a b. b -> Either a b
Right (Int
forall a. Additive a => a
zero::Int))
	 (Text -> Text
Text.init Text
s)
	Int
checksum <- Char -> Either ErrorToken Int
digitOfChar (Text -> Char
Text.last Text
s)
	if (Int
tot Int -> Int -> Int
forall a. Additive a => a -> a -> a
+ Int
checksum) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
53 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
	then Credential -> Either ErrorToken Credential
forall a b. b -> Either a b
Right (Text -> Credential
Credential Text
s)
	else ErrorToken -> Either ErrorToken Credential
forall a b. a -> Either a b
Left ErrorToken
ErrorToken_Checksum
	where
	digitOfChar :: Char -> Either ErrorToken Int
digitOfChar Char
c =
		Either ErrorToken Int
-> (Int -> Either ErrorToken Int)
-> Maybe Int
-> Either ErrorToken Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorToken -> Either ErrorToken Int
forall a b. a -> Either a b
Left (ErrorToken -> Either ErrorToken Int)
-> ErrorToken -> Either ErrorToken Int
forall a b. (a -> b) -> a -> b
$ Char -> ErrorToken
ErrorToken_BadChar Char
c) Int -> Either ErrorToken Int
forall a b. b -> Either a b
Right (Maybe Int -> Either ErrorToken Int)
-> Maybe Int -> Either ErrorToken Int
forall a b. (a -> b) -> a -> b
$
		Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Char
c String
credentialAlphabet

-- ** Type 'ErrorToken'
data ErrorToken
 =   ErrorToken_BadChar Char.Char
 |   ErrorToken_Checksum
 |   ErrorToken_Length
 deriving (ErrorToken -> ErrorToken -> Bool
(ErrorToken -> ErrorToken -> Bool)
-> (ErrorToken -> ErrorToken -> Bool) -> Eq ErrorToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorToken -> ErrorToken -> Bool
$c/= :: ErrorToken -> ErrorToken -> Bool
== :: ErrorToken -> ErrorToken -> Bool
$c== :: ErrorToken -> ErrorToken -> Bool
Eq,Int -> ErrorToken -> ShowS
[ErrorToken] -> ShowS
ErrorToken -> String
(Int -> ErrorToken -> ShowS)
-> (ErrorToken -> String)
-> ([ErrorToken] -> ShowS)
-> Show ErrorToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorToken] -> ShowS
$cshowList :: [ErrorToken] -> ShowS
show :: ErrorToken -> String
$cshow :: ErrorToken -> String
showsPrec :: Int -> ErrorToken -> ShowS
$cshowsPrec :: Int -> ErrorToken -> ShowS
Show,(forall x. ErrorToken -> Rep ErrorToken x)
-> (forall x. Rep ErrorToken x -> ErrorToken) -> Generic ErrorToken
forall x. Rep ErrorToken x -> ErrorToken
forall x. ErrorToken -> Rep ErrorToken x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrorToken x -> ErrorToken
$cfrom :: forall x. ErrorToken -> Rep ErrorToken x
Generic,ErrorToken -> ()
(ErrorToken -> ()) -> NFData ErrorToken
forall a. (a -> ()) -> NFData a
rnf :: ErrorToken -> ()
$crnf :: ErrorToken -> ()
NFData)

-- ** Type 'UUID'
newtype UUID = UUID Text
 deriving (UUID -> UUID -> Bool
(UUID -> UUID -> Bool) -> (UUID -> UUID -> Bool) -> Eq UUID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UUID -> UUID -> Bool
$c/= :: UUID -> UUID -> Bool
== :: UUID -> UUID -> Bool
$c== :: UUID -> UUID -> Bool
Eq,Eq UUID
Eq UUID
-> (UUID -> UUID -> Ordering)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> UUID)
-> (UUID -> UUID -> UUID)
-> Ord UUID
UUID -> UUID -> Bool
UUID -> UUID -> Ordering
UUID -> UUID -> UUID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UUID -> UUID -> UUID
$cmin :: UUID -> UUID -> UUID
max :: UUID -> UUID -> UUID
$cmax :: UUID -> UUID -> UUID
>= :: UUID -> UUID -> Bool
$c>= :: UUID -> UUID -> Bool
> :: UUID -> UUID -> Bool
$c> :: UUID -> UUID -> Bool
<= :: UUID -> UUID -> Bool
$c<= :: UUID -> UUID -> Bool
< :: UUID -> UUID -> Bool
$c< :: UUID -> UUID -> Bool
compare :: UUID -> UUID -> Ordering
$ccompare :: UUID -> UUID -> Ordering
$cp1Ord :: Eq UUID
Ord,Int -> UUID -> ShowS
[UUID] -> ShowS
UUID -> String
(Int -> UUID -> ShowS)
-> (UUID -> String) -> ([UUID] -> ShowS) -> Show UUID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UUID] -> ShowS
$cshowList :: [UUID] -> ShowS
show :: UUID -> String
$cshow :: UUID -> String
showsPrec :: Int -> UUID -> ShowS
$cshowsPrec :: Int -> UUID -> ShowS
Show,(forall x. UUID -> Rep UUID x)
-> (forall x. Rep UUID x -> UUID) -> Generic UUID
forall x. Rep UUID x -> UUID
forall x. UUID -> Rep UUID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UUID x -> UUID
$cfrom :: forall x. UUID -> Rep UUID x
Generic)
 deriving anyclass ([UUID] -> Encoding
[UUID] -> Value
UUID -> Encoding
UUID -> Value
(UUID -> Value)
-> (UUID -> Encoding)
-> ([UUID] -> Value)
-> ([UUID] -> Encoding)
-> ToJSON UUID
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UUID] -> Encoding
$ctoEncodingList :: [UUID] -> Encoding
toJSONList :: [UUID] -> Value
$ctoJSONList :: [UUID] -> Value
toEncoding :: UUID -> Encoding
$ctoEncoding :: UUID -> Encoding
toJSON :: UUID -> Value
$ctoJSON :: UUID -> Value
JSON.ToJSON)
 deriving newtype UUID -> ()
(UUID -> ()) -> NFData UUID
forall a. (a -> ()) -> NFData a
rnf :: UUID -> ()
$crnf :: UUID -> ()
NFData
instance JSON.FromJSON UUID where
	parseJSON :: Value -> Parser UUID
parseJSON json :: Value
json@(JSON.String Text
s) =
		(ErrorToken -> Parser UUID)
-> (UUID -> Parser UUID) -> Either ErrorToken UUID -> Parser UUID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ErrorToken
err -> String -> Value -> Parser UUID
forall a. String -> Value -> Parser a
JSON.typeMismatch (String
"UUID: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>ErrorToken -> String
forall a. Show a => a -> String
show ErrorToken
err) Value
json) UUID -> Parser UUID
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorToken UUID -> Parser UUID)
-> Either ErrorToken UUID -> Parser UUID
forall a b. (a -> b) -> a -> b
$
		Text -> Either ErrorToken UUID
readUUID Text
s
	parseJSON Value
json = String -> Value -> Parser UUID
forall a. String -> Value -> Parser a
JSON.typeMismatch String
"UUID" Value
json

-- | @'randomUUID'@ generates a random 'UUID'.
randomUUID ::
 Monad m =>
 Random.RandomGen r =>
 S.StateT r m UUID
randomUUID :: StateT r m UUID
randomUUID = do
	[Int]
rs <- Int -> StateT r m Int -> StateT r m [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
tokenLength (Int -> StateT r m Int
forall (m :: * -> *) r i.
(Monad m, RandomGen r, Random i, Ring i) =>
i -> StateT r m i
randomR (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tokenBase))
	UUID -> StateT r m UUID
forall (m :: * -> *) a. Monad m => a -> m a
return (UUID -> StateT r m UUID) -> UUID -> StateT r m UUID
forall a b. (a -> b) -> a -> b
$ Text -> UUID
UUID (Text -> UUID) -> Text -> UUID
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char
charOfDigit (Int -> Char) -> [Int] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
rs
	where
	charOfDigit :: Int -> Char
charOfDigit = (String
credentialAlphabet String -> Int -> Char
forall a. [a] -> Int -> a
List.!!)

-- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
-- from raw 'Text'.
readUUID :: Text -> Either ErrorToken UUID
readUUID :: Text -> Either ErrorToken UUID
readUUID Text
s
 | Text -> Int
Text.length Text
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
tokenLength = ErrorToken -> Either ErrorToken UUID
forall a b. a -> Either a b
Left ErrorToken
ErrorToken_Length
 | Bool
otherwise = do
	String -> (Char -> Either ErrorToken Int) -> Either ErrorToken ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Text -> String
Text.unpack Text
s) Char -> Either ErrorToken Int
digitOfChar
	UUID -> Either ErrorToken UUID
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> UUID
UUID Text
s)
	where
	digitOfChar :: Char -> Either ErrorToken Int
digitOfChar Char
c =
		Either ErrorToken Int
-> (Int -> Either ErrorToken Int)
-> Maybe Int
-> Either ErrorToken Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorToken -> Either ErrorToken Int
forall a b. a -> Either a b
Left (ErrorToken -> Either ErrorToken Int)
-> ErrorToken -> Either ErrorToken Int
forall a b. (a -> b) -> a -> b
$ Char -> ErrorToken
ErrorToken_BadChar Char
c) Int -> Either ErrorToken Int
forall a b. b -> Either a b
Right (Maybe Int -> Either ErrorToken Int)
-> Maybe Int -> Either ErrorToken Int
forall a b. (a -> b) -> a -> b
$
		Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Char
c String
credentialAlphabet