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 ^)