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