]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/Protocol/Credential.hs
protocol: polish extensions
[majurity.git] / hjugement-protocol / Protocol / Credential.hs
1 module Protocol.Credential where
2
3 import Control.Monad (Monad(..), replicateM)
4 import Data.Bits
5 import Data.Bool
6 import Data.Char (Char)
7 import Data.Either (Either(..))
8 import Data.Eq (Eq(..))
9 import Data.Function (($))
10 import Data.Functor ((<$>))
11 import Data.Int (Int)
12 import Data.Maybe (maybe)
13 import Data.Ord (Ord(..))
14 import Data.Text (Text)
15 import Numeric.Natural (Natural)
16 import Prelude (Integral(..), fromIntegral, div)
17 import Text.Show (Show)
18 import qualified Control.Monad.Trans.State.Strict as S
19 import qualified Crypto.KDF.PBKDF2 as Crypto
20 import qualified Data.ByteArray as ByteArray
21 import qualified Data.ByteString as BS
22 import qualified Data.Char as Char
23 import qualified Data.List as List
24 import qualified Data.Text as Text
25 import qualified Data.Text.Encoding as Text
26 import qualified System.Random as Random
27
28 import Protocol.Arithmetic
29
30 -- * Type 'Credential'
31 -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters
32 -- from a base alphabet of (@'tokenBase' '==' 58)@ characters:
33 -- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
34 -- (beware the absence of "0", \"O", \"I", and "l").
35 -- The last character is a checksum.
36 -- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.
37 newtype Credential = Credential Text
38 deriving (Eq, Show)
39
40 credentialAlphabet :: [Char] -- TODO: make this an array
41 credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
42 tokenBase :: Int
43 tokenBase = List.length credentialAlphabet
44 tokenLength ::Int
45 tokenLength = 14
46
47 -- | @'randomCredential'@ generates a random 'Credential'.
48 randomCredential ::
49 Monad m =>
50 Random.RandomGen r =>
51 S.StateT r m Credential
52 randomCredential = do
53 rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
54 let (tot, cs) = List.foldl' (\(acc,ds) d ->
55 ( acc * tokenBase + d
56 , charOfDigit d : ds )
57 ) (zero::Int, []) rs
58 let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?
59 return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)
60 where
61 charOfDigit = (credentialAlphabet List.!!)
62
63 -- | @'readCredential'@ reads and check the well-formedness of a 'Credential'
64 -- from raw 'Text'.
65 readCredential :: Text -> Either CredentialError Credential
66 readCredential s
67 | Text.length s /= tokenLength + 1 = Left CredentialError_Length
68 | otherwise = do
69 tot <- Text.foldl'
70 (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)
71 (Right (zero::Int))
72 (Text.init s)
73 checksum <- digitOfChar (Text.last s)
74 if (tot + checksum) `mod` 53 == 0
75 then Right (Credential s)
76 else Left CredentialError_Checksum
77 where
78 digitOfChar c =
79 maybe (Left $ CredentialError_BadChar c) Right $
80 List.elemIndex c credentialAlphabet
81
82 -- ** Type 'CredentialError'
83 data CredentialError
84 = CredentialError_BadChar Char.Char
85 | CredentialError_Checksum
86 | CredentialError_Length
87 deriving (Eq, Show)
88
89 -- ** Type 'UUID'
90 newtype UUID = UUID Text
91 deriving (Eq,Ord,Show)
92
93 -- | @'randomUUID'@ generates a random 'UUID'.
94 randomUUID ::
95 Monad m =>
96 Random.RandomGen r =>
97 S.StateT r m UUID
98 randomUUID = do
99 rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))
100 return $ UUID $ Text.pack $ charOfDigit <$> rs
101 where
102 charOfDigit = (credentialAlphabet List.!!)
103
104 -- ** Type 'SecretKey'
105 type SecretKey = E
106
107 -- | @('secretKey' uuid cred)@ returns the 'SecretKey'
108 -- derived from given 'uuid' and 'cred'
109 -- using 'Crypto.fastPBKDF2_SHA256'.
110 secretKey :: SubGroup q => UUID -> Credential -> SecretKey q
111 secretKey (UUID uuid) (Credential cred) =
112 fromNatural $ BS.foldl'
113 (\acc b -> acc`shiftL`3 + fromIntegral b)
114 (0::Natural)
115 (ByteArray.convert deriv)
116 where
117 deriv :: BS.ByteString
118 deriv =
119 Crypto.fastPBKDF2_SHA256
120 Crypto.Parameters
121 { Crypto.iterCounts = 1000
122 , Crypto.outputLength = 256 `div` 8
123 }
124 (Text.encodeUtf8 cred)
125 (Text.encodeUtf8 uuid)
126
127 -- ** Type 'PublicKey'
128 type PublicKey = G
129
130 -- | @('publicKey' secKey)@ returns the 'PublicKey'
131 -- derived from given 'SecretKey'.
132 publicKey :: SubGroup q => SecretKey q -> PublicKey q
133 publicKey = (groupGen ^)