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.Semigroup (Semigroup(..))
  18 import Data.Text (Text)
  19 import GHC.Generics (Generic)
  20 import Prelude (Integral(..), fromIntegral)
  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.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 Data.Text.Encoding as Text
  30 import qualified System.Random as Random
  31
  32 import Voting.Protocol.FFC
  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)
  43  deriving newtype NFData
  44  deriving newtype JSON.ToJSON
  45 instance JSON.FromJSON Credential where
  46         parseJSON json@(JSON.String s) =
  47                 either (\err -> JSON.typeMismatch ("Credential: "<>show err) json) return $
  48                 readCredential s
  49         parseJSON json = JSON.typeMismatch "Credential" json
  50
  51 credentialAlphabet :: [Char] -- TODO: make this an array
  52 credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
  53 tokenBase :: Int
  54 tokenBase = List.length credentialAlphabet
  55 tokenLength ::Int
  56 tokenLength = 14
  57
  58 -- | @'randomCredential'@ generates a random 'Credential'.
  59 randomCredential :: Monad m => Random.RandomGen r => S.StateT r m Credential
  60 randomCredential = do
  61         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
  62         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  63                         ( acc * tokenBase + d
  64                         , charOfDigit d : ds )
  65                  ) (zero::Int, []) rs
  66         let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
  67         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  68         where
  69         charOfDigit = (credentialAlphabet List.!!)
  70
  71 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
  72 -- from raw 'Text'.
  73 readCredential :: Text -> Either ErrorToken Credential
  74 readCredential s
  75  | Text.length s /= tokenLength + 1 = Left ErrorToken_Length
  76  | otherwise = do
  77         tot <- Text.foldl'
  78          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
  79          (Right (zero::Int))
  80          (Text.init s)
  81         checksum <- digitOfChar (Text.last s)
  82         if (tot + checksum) `mod` 53 == 0
  83         then Right (Credential s)
  84         else Left ErrorToken_Checksum
  85         where
  86         digitOfChar c =
  87                 maybe (Left $ ErrorToken_BadChar c) Right $
  88                 List.elemIndex c credentialAlphabet
  89
  90 -- ** Type 'ErrorToken'
  91 data ErrorToken
  92  =   ErrorToken_BadChar Char.Char
  93  |   ErrorToken_Checksum
  94  |   ErrorToken_Length
  95  deriving (Eq,Show,Generic,NFData)
  96
  97 -- ** Type 'UUID'
  98 newtype UUID = UUID Text
  99  deriving (Eq,Ord,Show,Generic)
 100  deriving anyclass (JSON.ToJSON)
 101  deriving newtype NFData
 102 instance JSON.FromJSON UUID where
 103         parseJSON json@(JSON.String s) =
 104                 either (\err -> JSON.typeMismatch ("UUID: "<>show err) json) return $
 105                 readUUID s
 106         parseJSON json = JSON.typeMismatch "UUID" json
 107
 108 -- | @'randomUUID'@ generates a random 'UUID'.
 109 randomUUID ::
 110  Monad m =>
 111  Random.RandomGen r =>
 112  S.StateT r m UUID
 113 randomUUID = do
 114         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
 115         return $ UUID $ Text.pack $ charOfDigit <$> rs
 116         where
 117         charOfDigit = (credentialAlphabet List.!!)
 118
 119 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
 120 -- from raw 'Text'.
 121 readUUID :: Text -> Either ErrorToken UUID
 122 readUUID s
 123  | Text.length s /= tokenLength = Left ErrorToken_Length
 124  | otherwise = do
 125         forM_ (Text.unpack s) digitOfChar
 126         return (UUID s)
 127         where
 128         digitOfChar c =
 129                 maybe (Left $ ErrorToken_BadChar c) Right $
 130                 List.elemIndex c credentialAlphabet
 131
 132 -- ** Type 'SecretKey'
 133 type SecretKey = E
 134
 135 randomSecretKey :: Reifies c FFC => Monad m => RandomGen r => S.StateT r m (SecretKey c)
 136 randomSecretKey = random
 137
 138 -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
 139 -- derived from given 'uuid' and 'cred'
 140 -- using 'Crypto.fastPBKDF2_SHA256'.
 141 credentialSecretKey :: Reifies c FFC => UUID -> Credential -> (SecretKey c)
 142 credentialSecretKey (UUID uuid) (Credential cred) =
 143         fromNatural $ decodeBigEndian $
 144         Crypto.fastPBKDF2_SHA256
 145          Crypto.Parameters
 146          { Crypto.iterCounts   = 1000
 147          , Crypto.outputLength = 32 -- bytes, ie. 256 bits
 148          }
 149          (Text.encodeUtf8 cred)
 150          (Text.encodeUtf8 uuid)
 151
 152 -- ** Type 'PublicKey'
 153 type PublicKey = G
 154
 155 -- | @('publicKey' secKey)@ returns the 'PublicKey'
 156 -- derived from given 'SecretKey' @secKey@.
 157 publicKey :: Reifies c FFC => SecretKey c -> PublicKey c
 158 publicKey = (groupGen ^)