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         let (tot, cs) = List.foldl' (\(acc,ds) d ->
 101                         ( acc * tokenBase + d
 102                         , charOfDigit d : ds )
 103                  ) (zero::Int, []) rs
 104         return $ UUID $ Text.reverse $ Text.pack cs
 105         where
 106         charOfDigit = (credentialAlphabet List.!!)
 107
 108 -- ** Type 'SecretKey'
 109 type SecretKey = E
 110
 111 -- | @('secretKey' uuid cred)@ returns the 'SecretKey'
 112 -- derived from given 'uuid' and 'cred'
 113 -- using 'Crypto.fastPBKDF2_SHA256'.
 114 secretKey :: SubGroup q => UUID -> Credential -> SecretKey q
 115 secretKey (UUID uuid) (Credential cred) =
 116         inE $ BS.foldl'
 117          (\acc b -> acc`shiftL`3 + fromIntegral b)
 118          (0::Natural)
 119          (ByteArray.convert deriv)
 120         where
 121         deriv :: BS.ByteString
 122         deriv =
 123                 Crypto.fastPBKDF2_SHA256
 124                  Crypto.Parameters
 125                  { Crypto.iterCounts   = 1000
 126                  , Crypto.outputLength = 256 `div` 8
 127                  }
 128                  (Text.encodeUtf8 cred)
 129                  (Text.encodeUtf8 uuid)
 130
 131 -- ** Type 'PublicKey'
 132 type PublicKey = G
 133
 134 -- | @('publicKey' secKey)@ returns the 'PublicKey'
 135 -- derived from given 'SecretKey' in @('SubGroup' q)@.
 136 publicKey :: SubGroup q => SecretKey q -> PublicKey q
 137 publicKey = (groupGen ^)