]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/Protocol/Credential.hs
protocol: Fix Credential
[majurity.git] / 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)