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.Arith
  32
  33 -- * Class 'Key'
  34 class Key crypto where
  35         -- | Type of cryptography, eg. "FFC".
  36         cryptoType :: crypto -> Text
  37         -- | Name of the cryptographic paramaters, eg. "Belenios".
  38         cryptoName :: crypto -> Text
  39         -- | Generate a random 'SecretKey'.
  40         randomSecretKey ::
  41          Reifies c crypto =>
  42          Monad m => Random.RandomGen r =>
  43          S.StateT r m (SecretKey crypto c)
  44         -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
  45         -- derived from given 'uuid' and 'cred'
  46         -- using 'Crypto.fastPBKDF2_SHA256'.
  47         credentialSecretKey ::
  48          Reifies c crypto =>
  49          UUID -> Credential -> SecretKey crypto c
  50         -- | @('publicKey' secKey)@ returns the 'PublicKey'
  51         -- derived from given 'SecretKey' @secKey@.
  52         publicKey ::
  53          Reifies c crypto =>
  54          SecretKey crypto c ->
  55          PublicKey crypto c
  56
  57 -- ** Type 'PublicKey'
  58 type PublicKey = G
  59 -- ** Type 'SecretKey'
  60 type SecretKey = E
  61
  62 -- * Type 'Credential'
  63 -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters
  64 -- from a base alphabet of (@'tokenBase' '==' 58)@ characters:
  65 -- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
  66 -- (beware the absence of "0", \"O", \"I", and "l").
  67 -- The last character is a checksum.
  68 -- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.
  69 newtype Credential = Credential Text
  70  deriving (Eq,Show,Generic)
  71  deriving newtype NFData
  72  deriving newtype JSON.ToJSON
  73 instance JSON.FromJSON Credential where
  74         parseJSON json@(JSON.String s) =
  75                 either (\err -> JSON.typeMismatch ("Credential: "<>show err) json) return $
  76                 readCredential s
  77         parseJSON json = JSON.typeMismatch "Credential" json
  78
  79 credentialAlphabet :: [Char] -- TODO: make this an array
  80 credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
  81 tokenBase :: Int
  82 tokenBase = List.length credentialAlphabet
  83 tokenLength ::Int
  84 tokenLength = 14
  85
  86 -- | @'randomCredential'@ generates a random 'Credential'.
  87 randomCredential :: Monad m => Random.RandomGen r => S.StateT r m Credential
  88 randomCredential = do
  89         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
  90         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  91                         ( acc * tokenBase + d
  92                         , charOfDigit d : ds )
  93                  ) (zero::Int, []) rs
  94         let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
  95         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  96         where
  97         charOfDigit = (credentialAlphabet List.!!)
  98
  99 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
 100 -- from raw 'Text'.
 101 readCredential :: Text -> Either ErrorToken Credential
 102 readCredential s
 103  | Text.length s /= tokenLength + 1 = Left ErrorToken_Length
 104  | otherwise = do
 105         tot <- Text.foldl'
 106          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
 107          (Right (zero::Int))
 108          (Text.init s)
 109         checksum <- digitOfChar (Text.last s)
 110         if (tot + checksum) `mod` 53 == 0
 111         then Right (Credential s)
 112         else Left ErrorToken_Checksum
 113         where
 114         digitOfChar c =
 115                 maybe (Left $ ErrorToken_BadChar c) Right $
 116                 List.elemIndex c credentialAlphabet
 117
 118 -- ** Type 'ErrorToken'
 119 data ErrorToken
 120  =   ErrorToken_BadChar Char.Char
 121  |   ErrorToken_Checksum
 122  |   ErrorToken_Length
 123  deriving (Eq,Show,Generic,NFData)
 124
 125 -- ** Type 'UUID'
 126 newtype UUID = UUID Text
 127  deriving (Eq,Ord,Show,Generic)
 128  deriving anyclass (JSON.ToJSON)
 129  deriving newtype NFData
 130 instance JSON.FromJSON UUID where
 131         parseJSON json@(JSON.String s) =
 132                 either (\err -> JSON.typeMismatch ("UUID: "<>show err) json) return $
 133                 readUUID s
 134         parseJSON json = JSON.typeMismatch "UUID" json
 135
 136 -- | @'randomUUID'@ generates a random 'UUID'.
 137 randomUUID ::
 138  Monad m =>
 139  Random.RandomGen r =>
 140  S.StateT r m UUID
 141 randomUUID = do
 142         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
 143         return $ UUID $ Text.pack $ charOfDigit <$> rs
 144         where
 145         charOfDigit = (credentialAlphabet List.!!)
 146
 147 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
 148 -- from raw 'Text'.
 149 readUUID :: Text -> Either ErrorToken UUID
 150 readUUID s
 151  | Text.length s /= tokenLength = Left ErrorToken_Length
 152  | otherwise = do
 153         forM_ (Text.unpack s) digitOfChar
 154         return (UUID s)
 155         where
 156         digitOfChar c =
 157                 maybe (Left $ ErrorToken_BadChar c) Right $
 158                 List.elemIndex c credentialAlphabet