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 -- | @'randomCredential'@ generates a random credential.
  36 randomCredential ::
  37  forall m p r.
  38  Monad m =>
  39  PrimeField p =>
  40  Random.RandomGen r =>
  41  S.StateT r m (Credential p)
  42 randomCredential = do
  43         rs <- replicateM tokenLength (randomR (fromIntegral (unF tokenBase)))
  44         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  45                         ( acc * tokenBase + inF d
  46                         , charOfDigit d : ds
  47                         )
  48                  ) (zero::F p, []) rs
  49         let checksum = 53 - fromIntegral (unF tot `mod` 53)
  50         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  51         where
  52         charOfDigit d
  53          | d < 9      = Char.chr (Char.ord '1'+d)
  54          | d < (9+26) = Char.chr (Char.ord 'A'+d-9)
  55          | otherwise  = Char.chr (Char.ord 'a'+d-9-26)
  56
  57 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
  58 -- from raw 'Text'.
  59 readCredential ::
  60  forall p.
  61  PrimeField p =>
  62  Text -> Either CredentialError (Credential p)
  63 readCredential s
  64  | Text.length s /= tokenLength + 1 = Left CredentialError_Length
  65  | otherwise = do
  66         tot <- Text.foldl'
  67          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
  68          (Right (zero::F p))
  69          (Text.init s)
  70         checksum <- digitOfChar (Text.last s)
  71         if unF (tot + checksum) `mod` 53 == 0
  72         then Right (Credential s)
  73         else Left CredentialError_Checksum
  74         where
  75         digitOfChar c
  76          | c <  '1'  = err
  77          | c <= '9'  = Right (inF $ Char.ord c - Char.ord '1')
  78          | c <  'A'  = err
  79          | c <= 'Z'  = Right (inF $ Char.ord c - Char.ord 'A' + 9)
  80          | c <  'a'  = err
  81          | c <= 'z'  = Right (inF $ Char.ord c - Char.ord 'a' + 9 + 26)
  82          | otherwise = err
  83          where err = Left $ CredentialError_BadChar c
  84
  85 -- ** Type 'CredentialError'
  86 data CredentialError
  87  =   CredentialError_BadChar Char.Char
  88  |   CredentialError_Checksum
  89  |   CredentialError_Length
  90  deriving (Eq, Show)