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