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 ::
  53  Monad m =>
  54  Random.RandomGen r =>
  55  S.StateT r m Credential
  56 randomCredential = do
  57         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
  58         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  59                         ( acc * tokenBase + d
  60                         , charOfDigit d : ds )
  61                  ) (zero::Int, []) rs
  62         let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
  63         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  64         where
  65         charOfDigit = (credentialAlphabet List.!!)
  66
  67 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
  68 -- from raw 'Text'.
  69 readCredential :: Text -> Either CredentialError Credential
  70 readCredential s
  71  | Text.length s /= tokenLength + 1 = Left CredentialError_Length
  72  | otherwise = do
  73         tot <- Text.foldl'
  74          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
  75          (Right (zero::Int))
  76          (Text.init s)
  77         checksum <- digitOfChar (Text.last s)
  78         if (tot + checksum) `mod` 53 == 0
  79         then Right (Credential s)
  80         else Left CredentialError_Checksum
  81         where
  82         digitOfChar c =
  83                 maybe (Left $ CredentialError_BadChar c) Right $
  84                 List.elemIndex c credentialAlphabet
  85
  86 -- ** Type 'CredentialError'
  87 data CredentialError
  88  =   CredentialError_BadChar Char.Char
  89  |   CredentialError_Checksum
  90  |   CredentialError_Length
  91  deriving (Eq,Show,Generic,NFData)
  92
  93 -- ** Type 'UUID'
  94 newtype UUID = UUID Text
  95  deriving (Eq,Ord,Show,Generic,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 -- | @('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 ^)