78 lines
2.1 KiB
Haskell
78 lines
2.1 KiB
Haskell
|
|
module ModelCustom where
|
|
|
|
import Prelude
|
|
|
|
import Crypto.BCrypt as Import hiding (hashPassword)
|
|
import Database.Persist.Sql
|
|
import Safe (fromJustNote)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Aeson as A
|
|
import System.Entropy (getEntropy)
|
|
import qualified Data.ByteString.Builder as BB
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.ByteString.Base64.URL as Base64Url
|
|
import qualified Crypto.Hash.SHA256 as SHA256
|
|
|
|
mkSlug :: Int -> IO T.Text
|
|
mkSlug size =
|
|
TE.decodeUtf8 . LBS.toStrict . BB.toLazyByteString . BB.byteStringHex <$>
|
|
getEntropy size
|
|
|
|
-- * Bookmark Slug
|
|
|
|
newtype BmSlug = BmSlug
|
|
{ unBmSlug :: T.Text
|
|
} deriving (Eq, PersistField, PersistFieldSql, Show, Read, Ord, A.FromJSON, A.ToJSON)
|
|
|
|
mkBmSlug :: IO BmSlug
|
|
mkBmSlug = BmSlug <$> mkSlug 6
|
|
|
|
-- * Note Slug
|
|
|
|
newtype NtSlug = NtSlug
|
|
{ unNtSlug :: T.Text
|
|
} deriving (Eq, PersistField, PersistFieldSql, Show, Read, Ord, A.FromJSON, A.ToJSON)
|
|
|
|
mkNtSlug :: IO NtSlug
|
|
mkNtSlug = NtSlug <$> mkSlug 10
|
|
|
|
-- * Model Crypto
|
|
|
|
policy :: HashingPolicy
|
|
policy =
|
|
HashingPolicy
|
|
{ preferredHashCost = 12
|
|
, preferredHashAlgorithm = "$2a$"
|
|
}
|
|
|
|
newtype BCrypt = BCrypt
|
|
{ unBCrypt :: T.Text
|
|
} deriving (Eq, PersistField, PersistFieldSql, Show, Ord, A.FromJSON, A.ToJSON)
|
|
|
|
hashPassword :: T.Text -> IO BCrypt
|
|
hashPassword rawPassword = do
|
|
mPassword <- hashPasswordUsingPolicy policy (TE.encodeUtf8 rawPassword)
|
|
return
|
|
(BCrypt (TE.decodeUtf8 (fromJustNote "Invalid hashing policy" mPassword)))
|
|
|
|
validatePasswordHash :: BCrypt -> T.Text -> Bool
|
|
validatePasswordHash hash' pass = do
|
|
validatePassword (TE.encodeUtf8 (unBCrypt hash')) (TE.encodeUtf8 pass)
|
|
|
|
newtype ApiKey = ApiKey { unApiKey :: T.Text }
|
|
|
|
newtype HashedApiKey
|
|
= HashedApiKey T.Text
|
|
deriving stock (Eq, Ord, Show)
|
|
deriving newtype (PersistField, PersistFieldSql, A.FromJSON, A.ToJSON)
|
|
|
|
generateApiKey :: IO ApiKey
|
|
generateApiKey = do
|
|
bytes <- getEntropy 32
|
|
pure $ ApiKey $ Base64Url.encodeBase64 bytes
|
|
|
|
hashApiKey :: ApiKey -> HashedApiKey
|
|
hashApiKey = HashedApiKey . TE.decodeUtf8 . Base64Url.encodeBase64' . SHA256.hash . TE.encodeUtf8 . unApiKey
|