hjugement-protocol/src/Voting/Protocol/Credential.hs

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