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(..), replicateM)
   8 import Data.Bits
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Function (($))
  14 import Data.Functor ((<$>))
  15 import Data.Int (Int)
  16 import Data.Maybe (maybe)
  17 import Data.Ord (Ord(..))
  18 import Data.Text (Text)
  19 import GHC.Generics (Generic)
  20 import Numeric.Natural (Natural)
  21 import Prelude (Integral(..), fromIntegral, div)
  22 import Text.Show (Show)
  23 import qualified Control.Monad.Trans.State.Strict as S
  24 import qualified Crypto.KDF.PBKDF2 as Crypto
  25 import qualified Data.ByteArray as ByteArray
  26 import qualified Data.ByteString as BS
  27 import qualified Data.Char as Char
  28 import qualified Data.List as List
  29 import qualified Data.Text as Text
  30 import qualified Data.Text.Encoding as Text
  31 import qualified System.Random as Random
  32
  33 import Voting.Protocol.Arithmetic
  34
  35 -- * Type 'Credential'
  36 -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters
  37 -- from a base alphabet of (@'tokenBase' '==' 58)@ characters:
  38 -- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
  39 -- (beware the absence of "0", \"O", \"I", and "l").
  40 -- The last character is a checksum.
  41 -- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.
  42 newtype Credential = Credential Text
  43  deriving (Eq,Show,Generic)
  44  deriving newtype NFData
  45
  46 credentialAlphabet :: [Char] -- TODO: make this an array
  47 credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
  48 tokenBase :: Int
  49 tokenBase = List.length credentialAlphabet
  50 tokenLength ::Int
  51 tokenLength = 14
  52
  53 -- | @'randomCredential'@ generates a random 'Credential'.
  54 randomCredential :: Monad m => Random.RandomGen r => S.StateT r m Credential
  55 randomCredential = do
  56         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
  57         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  58                         ( acc * tokenBase + d
  59                         , charOfDigit d : ds )
  60                  ) (zero::Int, []) rs
  61         let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
  62         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  63         where
  64         charOfDigit = (credentialAlphabet List.!!)
  65
  66 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
  67 -- from raw 'Text'.
  68 readCredential :: Text -> Either CredentialError Credential
  69 readCredential s
  70  | Text.length s /= tokenLength + 1 = Left CredentialError_Length
  71  | otherwise = do
  72         tot <- Text.foldl'
  73          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
  74          (Right (zero::Int))
  75          (Text.init s)
  76         checksum <- digitOfChar (Text.last s)
  77         if (tot + checksum) `mod` 53 == 0
  78         then Right (Credential s)
  79         else Left CredentialError_Checksum
  80         where
  81         digitOfChar c =
  82                 maybe (Left $ CredentialError_BadChar c) Right $
  83                 List.elemIndex c credentialAlphabet
  84
  85 -- ** Type 'CredentialError'
  86 data CredentialError
  87  =   CredentialError_BadChar Char.Char
  88  |   CredentialError_Checksum
  89  |   CredentialError_Length
  90  deriving (Eq,Show,Generic,NFData)
  91
  92 -- ** Type 'UUID'
  93 newtype UUID = UUID Text
  94  deriving (Eq,Ord,Show,Generic)
  95  deriving newtype NFData
  96
  97 -- | @'randomUUID'@ generates a random 'UUID'.
  98 randomUUID ::
  99  Monad m =>
 100  Random.RandomGen r =>
 101  S.StateT r m UUID
 102 randomUUID = do
 103         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
 104         return $ UUID $ Text.pack $ charOfDigit <$> rs
 105         where
 106         charOfDigit = (credentialAlphabet List.!!)
 107
 108 -- ** Type 'SecretKey'
 109 type SecretKey = E
 110
 111 randomSecretKey :: Monad m => RandomGen r => SubGroup q => S.StateT r m (SecretKey q)
 112 randomSecretKey = random
 113
 114 -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
 115 -- derived from given 'uuid' and 'cred'
 116 -- using 'Crypto.fastPBKDF2_SHA256'.
 117 credentialSecretKey :: SubGroup q => UUID -> Credential -> SecretKey q
 118 credentialSecretKey (UUID uuid) (Credential cred) =
 119         fromNatural $ BS.foldl'
 120          (\acc b -> acc`shiftL`3 + fromIntegral b)
 121          (0::Natural)
 122          (ByteArray.convert deriv)
 123         where
 124         deriv :: BS.ByteString
 125         deriv =
 126                 Crypto.fastPBKDF2_SHA256
 127                  Crypto.Parameters
 128                  { Crypto.iterCounts   = 1000
 129                  , Crypto.outputLength = 256 `div` 8
 130                  }
 131                  (Text.encodeUtf8 cred)
 132                  (Text.encodeUtf8 uuid)
 133
 134 -- ** Type 'PublicKey'
 135 type PublicKey = G
 136
 137 -- | @('publicKey' secKey)@ returns the 'PublicKey'
 138 -- derived from given 'SecretKey'.
 139 publicKey :: SubGroup q => SecretKey q -> PublicKey q
 140 publicKey = (groupGen ^)