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