]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/src/Voting/Protocol/Credential.hs
cli: admin: directly use election_hash
[majurity.git] / hjugement-protocol / src / Voting / Protocol / Credential.hs
1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE DerivingStrategies #-}
4 module Voting.Protocol.Credential where
5
6 import Control.DeepSeq (NFData)
7 import Control.Monad (Monad(..), forM_, replicateM)
8 import Data.Bool
9 import Data.Char (Char)
10 import Data.Either (Either(..), either)
11 import Data.Eq (Eq(..))
12 import Data.Function (($))
13 import Data.Functor ((<$>))
14 import Data.Int (Int)
15 import Data.Maybe (maybe)
16 import Data.Ord (Ord(..))
17 import Data.Reflection (Reifies(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.Text (Text)
20 import GHC.Generics (Generic)
21 import Prelude (Integral(..), fromIntegral)
22 import Text.Show (Show(..))
23 import qualified Control.Monad.Trans.State.Strict as S
24 import qualified Data.Aeson as JSON
25 import qualified Data.Aeson.Types as JSON
26 import qualified Data.Char as Char
27 import qualified Data.List as List
28 import qualified Data.Text as Text
29 import qualified System.Random as Random
30
31 import Voting.Protocol.Arithmetic
32 import Voting.Protocol.Cryptography
33
34 -- * Class 'Key'
35 class Key crypto where
36 -- | Type of cryptography, eg. "FFC".
37 cryptoType :: crypto -> Text
38 -- | Name of the cryptographic paramaters, eg. "Belenios".
39 cryptoName :: crypto -> Text
40 -- | Generate a random 'SecretKey'.
41 randomSecretKey ::
42 Reifies c crypto =>
43 Monad m => Random.RandomGen r =>
44 S.StateT r m (SecretKey crypto c)
45 -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
46 -- derived from given 'uuid' and 'cred'
47 -- using 'Crypto.fastPBKDF2_SHA256'.
48 credentialSecretKey ::
49 Reifies c crypto =>
50 UUID -> Credential -> SecretKey crypto c
51 -- | @('publicKey' secKey)@ returns the 'PublicKey'
52 -- derived from given 'SecretKey' @secKey@.
53 publicKey ::
54 Reifies c crypto =>
55 SecretKey crypto c ->
56 PublicKey crypto c
57
58 -- * Type 'Credential'
59 -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters
60 -- from a base alphabet of (@'tokenBase' '==' 58)@ characters:
61 -- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
62 -- (beware the absence of "0", \"O", \"I", and "l").
63 -- The last character is a checksum.
64 -- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.
65 newtype Credential = Credential Text
66 deriving (Eq,Show,Generic)
67 deriving newtype NFData
68 deriving newtype JSON.ToJSON
69 instance JSON.FromJSON Credential where
70 parseJSON json@(JSON.String s) =
71 either (\err -> JSON.typeMismatch ("Credential: "<>show err) json) return $
72 readCredential s
73 parseJSON json = JSON.typeMismatch "Credential" json
74
75 credentialAlphabet :: [Char] -- TODO: make this an array
76 credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
77 tokenBase :: Int
78 tokenBase = List.length credentialAlphabet
79 tokenLength ::Int
80 tokenLength = 14
81
82 -- | @'randomCredential'@ generates a random 'Credential'.
83 randomCredential :: Monad m => Random.RandomGen r => S.StateT r m Credential
84 randomCredential = do
85 rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
86 let (tot, cs) = List.foldl' (\(acc,ds) d ->
87 ( acc * tokenBase + d
88 , charOfDigit d : ds )
89 ) (zero::Int, []) rs
90 let checksum = (negate tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
91 return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
92 where
93 charOfDigit = (credentialAlphabet List.!!)
94
95 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
96 -- from raw 'Text'.
97 readCredential :: Text -> Either ErrorToken Credential
98 readCredential s
99 | Text.length s /= tokenLength + 1 = Left ErrorToken_Length
100 | otherwise = do
101 tot <- Text.foldl'
102 (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
103 (Right (zero::Int))
104 (Text.init s)
105 checksum <- digitOfChar (Text.last s)
106 if (tot + checksum) `mod` 53 == 0
107 then Right (Credential s)
108 else Left ErrorToken_Checksum
109 where
110 digitOfChar c =
111 maybe (Left $ ErrorToken_BadChar c) Right $
112 List.elemIndex c credentialAlphabet
113
114 -- ** Type 'ErrorToken'
115 data ErrorToken
116 = ErrorToken_BadChar Char.Char
117 | ErrorToken_Checksum
118 | ErrorToken_Length
119 deriving (Eq,Show,Generic,NFData)
120
121 -- ** Type 'UUID'
122 newtype UUID = UUID Text
123 deriving (Eq,Ord,Show,Generic)
124 deriving anyclass (JSON.ToJSON)
125 deriving newtype NFData
126 instance JSON.FromJSON UUID where
127 parseJSON json@(JSON.String s) =
128 either (\err -> JSON.typeMismatch ("UUID: "<>show err) json) return $
129 readUUID s
130 parseJSON json = JSON.typeMismatch "UUID" json
131
132 -- | @'randomUUID'@ generates a random 'UUID'.
133 randomUUID ::
134 Monad m =>
135 Random.RandomGen r =>
136 S.StateT r m UUID
137 randomUUID = do
138 rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
139 return $ UUID $ Text.pack $ charOfDigit <$> rs
140 where
141 charOfDigit = (credentialAlphabet List.!!)
142
143 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
144 -- from raw 'Text'.
145 readUUID :: Text -> Either ErrorToken UUID
146 readUUID s
147 | Text.length s /= tokenLength = Left ErrorToken_Length
148 | otherwise = do
149 forM_ (Text.unpack s) digitOfChar
150 return (UUID s)
151 where
152 digitOfChar c =
153 maybe (Left $ ErrorToken_BadChar c) Right $
154 List.elemIndex c credentialAlphabet