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.Arithmetic
  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 = Credential Text
  32  deriving (Eq, Show)
  33
  34 credentialAlphabet :: [Char]
  35 credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
  36 tokenBase :: Int
  37 tokenBase = List.length credentialAlphabet
  38 tokenLength ::Int
  39 tokenLength = 14
  40
  41 -- | @'randomCredential'@ generates a random 'Credential'.
  42 randomCredential ::
  43  Monad m =>
  44  Random.RandomGen r =>
  45  S.StateT r m Credential
  46 randomCredential = do
  47         rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
  48         let (tot, cs) = List.foldl' (\(acc,ds) d ->
  49                         ( acc * tokenBase + d
  50                         , charOfDigit d : ds )
  51                  ) (zero::Int, []) rs
  52         let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
  53         return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
  54         where
  55         charOfDigit = (credentialAlphabet List.!!)
  56
  57 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
  58 -- from raw 'Text'.
  59 readCredential :: Text -> Either CredentialError Credential
  60 readCredential s
  61  | Text.length s /= tokenLength + 1 = Left CredentialError_Length
  62  | otherwise = do
  63         tot <- Text.foldl'
  64          (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
  65          (Right (zero::Int))
  66          (Text.init s)
  67         checksum <- digitOfChar (Text.last s)
  68         if (tot + checksum) `mod` 53 == 0
  69         then Right (Credential s)
  70         else Left CredentialError_Checksum
  71         where
  72         digitOfChar c =
  73                 maybe (Left $ CredentialError_BadChar c) Right $
  74                 List.elemIndex c credentialAlphabet
  75
  76 -- ** Type 'CredentialError'
  77 data CredentialError
  78  =   CredentialError_BadChar Char.Char
  79  |   CredentialError_Checksum
  80  |   CredentialError_Length
  81  deriving (Eq, Show)