hjugement-protocol/Protocol/Credential.hs

   1 module Protocol.Credential where
   2
   3 import Control.Monad (Monad(..), replicateM)
   4 import Data.Bool
   5 import Data.Eq (Eq(..))
   6 import Data.Either (Either(..))
   7 import Data.Function (($), (.))
   8 import Data.Functor ((<$>))
   9 import Data.Int (Int)
  10 import Data.Ord (Ord(..))
  11 import Data.Text (Text)
  12 import Prelude (Integral(..), fromIntegral)
  13 import Text.Show (Show)
  14 import qualified Control.Monad.Trans.State.Strict as S
  15 import qualified Data.Char as Char
  16 import qualified Data.List as List
  17 import qualified Data.Text as Text
  18 import qualified System.Random as Random
  19
  20 import Protocol.Arith
  21
  22 -- * Type 'Credential'
  23 -- | A 'Credential' is a word of 15-characters from the alphabet:
  24 -- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz".
  25 -- The last character is a checksum.
  26 -- The entropy is: @(14 * log (9+26+26) / log 2) ~ 83.03 bits@.
  27 newtype Credential p = Credential Text
  28  deriving (Eq, Show)
  29
  30 tokenBase :: F p
  31 tokenBase = F (9+26+26)
  32 tokenLength ::Int
  33 tokenLength = 14
  34
  35 random ::
  36  Monad m =>
  37  Random.RandomGen r =>
  38  Random.Random i =>
  39  Negable i =>
  40  Multiplicative i =>
  41  i -> S.StateT r m i
  42 random i = S.StateT $ return . Random.randomR (zero, i-one)
  43
  44 -- | @'randomCredential'@ generates a random credential.
  45 randomCredential ::
  46  forall m p r.
  47  Monad m =>
  48  PrimeField p =>
  49  Random.RandomGen r =>
  50  S.StateT r m (Credential p)
  51 randomCredential = do
  52         rs <- replicateM tokenLength (random (fromIntegral (unF tokenBase)))
  53         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  54                         ( acc * tokenBase + F (fromIntegral d)
  55                         , charOfDigit d : ds
  56                         )
  57                  ) (zero::F p, []) rs
  58         let checksum = 53 - fromIntegral (unF tot `mod` 53)
  59         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  60         where
  61         charOfDigit d
  62          | d < 9      = Char.chr (Char.ord '1'+d)
  63          | d < (9+26) = Char.chr (Char.ord 'A'+d-9)
  64          | otherwise  = Char.chr (Char.ord 'a'+d-9-26)
  65
  66 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
  67 -- from raw 'Text'.
  68 readCredential ::
  69  forall p.
  70  PrimeField p =>
  71  Text -> Either CredentialError (Credential p)
  72 readCredential s
  73  | Text.length s /= tokenLength + 1 = Left CredentialError_Length
  74  | otherwise = do
  75         tot <- Text.foldl'
  76          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
  77          (Right (zero::F p))
  78          (Text.init s)
  79         checksum <- digitOfChar (Text.last s)
  80         if unF (tot + checksum) `mod` 53 == 0
  81         then Right (Credential s)
  82         else Left CredentialError_Checksum
  83         where
  84         digitOfChar c
  85          | c <  '1'  = err
  86          | c <= '9'  = Right (primeField $ Char.ord c - Char.ord '1')
  87          | c <  'A'  = err
  88          | c <= 'Z'  = Right (primeField $ Char.ord c - Char.ord 'A' + 9)
  89          | c <  'a'  = err
  90          | c <= 'z'  = Right (primeField $ Char.ord c - Char.ord 'a' + 9 + 26)
  91          | otherwise = err
  92          where err = Left $ CredentialError_BadChar c
  93
  94 -- ** Type 'CredentialError'
  95 data CredentialError
  96  =   CredentialError_BadChar Char.Char
  97  |   CredentialError_Checksum
  98  |   CredentialError_Length
  99  deriving (Eq, Show)