hjugement-protocol/Protocol/Credential.hs

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