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 :: Int -> IO Text
mkSlug Int
size =
  ByteString -> Text
TE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BB.byteStringHex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  Int -> IO ByteString
getEntropy Int
size

-- * Bookmark Slug

newtype BmSlug = BmSlug
  { BmSlug -> Text
unBmSlug :: T.Text
  } deriving (BmSlug -> BmSlug -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BmSlug -> BmSlug -> Bool
$c/= :: BmSlug -> BmSlug -> Bool
== :: BmSlug -> BmSlug -> Bool
$c== :: BmSlug -> BmSlug -> Bool
Eq, PersistValue -> Either Text BmSlug
BmSlug -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text BmSlug
$cfromPersistValue :: PersistValue -> Either Text BmSlug
toPersistValue :: BmSlug -> PersistValue
$ctoPersistValue :: BmSlug -> PersistValue
PersistField, PersistField BmSlug
Proxy BmSlug -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy BmSlug -> SqlType
$csqlType :: Proxy BmSlug -> SqlType
PersistFieldSql, Int -> BmSlug -> ShowS
[BmSlug] -> ShowS
BmSlug -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BmSlug] -> ShowS
$cshowList :: [BmSlug] -> ShowS
show :: BmSlug -> String
$cshow :: BmSlug -> String
showsPrec :: Int -> BmSlug -> ShowS
$cshowsPrec :: Int -> BmSlug -> ShowS
Show, ReadPrec [BmSlug]
ReadPrec BmSlug
Int -> ReadS BmSlug
ReadS [BmSlug]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BmSlug]
$creadListPrec :: ReadPrec [BmSlug]
readPrec :: ReadPrec BmSlug
$creadPrec :: ReadPrec BmSlug
readList :: ReadS [BmSlug]
$creadList :: ReadS [BmSlug]
readsPrec :: Int -> ReadS BmSlug
$creadsPrec :: Int -> ReadS BmSlug
Read, Eq BmSlug
BmSlug -> BmSlug -> Bool
BmSlug -> BmSlug -> Ordering
BmSlug -> BmSlug -> BmSlug
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BmSlug -> BmSlug -> BmSlug
$cmin :: BmSlug -> BmSlug -> BmSlug
max :: BmSlug -> BmSlug -> BmSlug
$cmax :: BmSlug -> BmSlug -> BmSlug
>= :: BmSlug -> BmSlug -> Bool
$c>= :: BmSlug -> BmSlug -> Bool
> :: BmSlug -> BmSlug -> Bool
$c> :: BmSlug -> BmSlug -> Bool
<= :: BmSlug -> BmSlug -> Bool
$c<= :: BmSlug -> BmSlug -> Bool
< :: BmSlug -> BmSlug -> Bool
$c< :: BmSlug -> BmSlug -> Bool
compare :: BmSlug -> BmSlug -> Ordering
$ccompare :: BmSlug -> BmSlug -> Ordering
Ord, Value -> Parser [BmSlug]
Value -> Parser BmSlug
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BmSlug]
$cparseJSONList :: Value -> Parser [BmSlug]
parseJSON :: Value -> Parser BmSlug
$cparseJSON :: Value -> Parser BmSlug
A.FromJSON, [BmSlug] -> Encoding
[BmSlug] -> Value
BmSlug -> Encoding
BmSlug -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BmSlug] -> Encoding
$ctoEncodingList :: [BmSlug] -> Encoding
toJSONList :: [BmSlug] -> Value
$ctoJSONList :: [BmSlug] -> Value
toEncoding :: BmSlug -> Encoding
$ctoEncoding :: BmSlug -> Encoding
toJSON :: BmSlug -> Value
$ctoJSON :: BmSlug -> Value
A.ToJSON)

mkBmSlug :: IO BmSlug
mkBmSlug :: IO BmSlug
mkBmSlug = Text -> BmSlug
BmSlug forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
mkSlug Int
6

-- * Note Slug

newtype NtSlug = NtSlug
  { NtSlug -> Text
unNtSlug :: T.Text
  } deriving (NtSlug -> NtSlug -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NtSlug -> NtSlug -> Bool
$c/= :: NtSlug -> NtSlug -> Bool
== :: NtSlug -> NtSlug -> Bool
$c== :: NtSlug -> NtSlug -> Bool
Eq, PersistValue -> Either Text NtSlug
NtSlug -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text NtSlug
$cfromPersistValue :: PersistValue -> Either Text NtSlug
toPersistValue :: NtSlug -> PersistValue
$ctoPersistValue :: NtSlug -> PersistValue
PersistField, PersistField NtSlug
Proxy NtSlug -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy NtSlug -> SqlType
$csqlType :: Proxy NtSlug -> SqlType
PersistFieldSql, Int -> NtSlug -> ShowS
[NtSlug] -> ShowS
NtSlug -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NtSlug] -> ShowS
$cshowList :: [NtSlug] -> ShowS
show :: NtSlug -> String
$cshow :: NtSlug -> String
showsPrec :: Int -> NtSlug -> ShowS
$cshowsPrec :: Int -> NtSlug -> ShowS
Show, ReadPrec [NtSlug]
ReadPrec NtSlug
Int -> ReadS NtSlug
ReadS [NtSlug]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NtSlug]
$creadListPrec :: ReadPrec [NtSlug]
readPrec :: ReadPrec NtSlug
$creadPrec :: ReadPrec NtSlug
readList :: ReadS [NtSlug]
$creadList :: ReadS [NtSlug]
readsPrec :: Int -> ReadS NtSlug
$creadsPrec :: Int -> ReadS NtSlug
Read, Eq NtSlug
NtSlug -> NtSlug -> Bool
NtSlug -> NtSlug -> Ordering
NtSlug -> NtSlug -> NtSlug
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NtSlug -> NtSlug -> NtSlug
$cmin :: NtSlug -> NtSlug -> NtSlug
max :: NtSlug -> NtSlug -> NtSlug
$cmax :: NtSlug -> NtSlug -> NtSlug
>= :: NtSlug -> NtSlug -> Bool
$c>= :: NtSlug -> NtSlug -> Bool
> :: NtSlug -> NtSlug -> Bool
$c> :: NtSlug -> NtSlug -> Bool
<= :: NtSlug -> NtSlug -> Bool
$c<= :: NtSlug -> NtSlug -> Bool
< :: NtSlug -> NtSlug -> Bool
$c< :: NtSlug -> NtSlug -> Bool
compare :: NtSlug -> NtSlug -> Ordering
$ccompare :: NtSlug -> NtSlug -> Ordering
Ord, Value -> Parser [NtSlug]
Value -> Parser NtSlug
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NtSlug]
$cparseJSONList :: Value -> Parser [NtSlug]
parseJSON :: Value -> Parser NtSlug
$cparseJSON :: Value -> Parser NtSlug
A.FromJSON, [NtSlug] -> Encoding
[NtSlug] -> Value
NtSlug -> Encoding
NtSlug -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NtSlug] -> Encoding
$ctoEncodingList :: [NtSlug] -> Encoding
toJSONList :: [NtSlug] -> Value
$ctoJSONList :: [NtSlug] -> Value
toEncoding :: NtSlug -> Encoding
$ctoEncoding :: NtSlug -> Encoding
toJSON :: NtSlug -> Value
$ctoJSON :: NtSlug -> Value
A.ToJSON)

mkNtSlug :: IO NtSlug
mkNtSlug :: IO NtSlug
mkNtSlug = Text -> NtSlug
NtSlug forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
mkSlug Int
10

-- * Model Crypto

policy :: HashingPolicy
policy :: HashingPolicy
policy =
  HashingPolicy
  { preferredHashCost :: Int
preferredHashCost = Int
12
  , preferredHashAlgorithm :: ByteString
preferredHashAlgorithm = ByteString
"$2a$"
  }

newtype BCrypt = BCrypt
  { BCrypt -> Text
unBCrypt :: T.Text
  } deriving (BCrypt -> BCrypt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BCrypt -> BCrypt -> Bool
$c/= :: BCrypt -> BCrypt -> Bool
== :: BCrypt -> BCrypt -> Bool
$c== :: BCrypt -> BCrypt -> Bool
Eq, PersistValue -> Either Text BCrypt
BCrypt -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text BCrypt
$cfromPersistValue :: PersistValue -> Either Text BCrypt
toPersistValue :: BCrypt -> PersistValue
$ctoPersistValue :: BCrypt -> PersistValue
PersistField, PersistField BCrypt
Proxy BCrypt -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy BCrypt -> SqlType
$csqlType :: Proxy BCrypt -> SqlType
PersistFieldSql, Int -> BCrypt -> ShowS
[BCrypt] -> ShowS
BCrypt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BCrypt] -> ShowS
$cshowList :: [BCrypt] -> ShowS
show :: BCrypt -> String
$cshow :: BCrypt -> String
showsPrec :: Int -> BCrypt -> ShowS
$cshowsPrec :: Int -> BCrypt -> ShowS
Show, Eq BCrypt
BCrypt -> BCrypt -> Bool
BCrypt -> BCrypt -> Ordering
BCrypt -> BCrypt -> BCrypt
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BCrypt -> BCrypt -> BCrypt
$cmin :: BCrypt -> BCrypt -> BCrypt
max :: BCrypt -> BCrypt -> BCrypt
$cmax :: BCrypt -> BCrypt -> BCrypt
>= :: BCrypt -> BCrypt -> Bool
$c>= :: BCrypt -> BCrypt -> Bool
> :: BCrypt -> BCrypt -> Bool
$c> :: BCrypt -> BCrypt -> Bool
<= :: BCrypt -> BCrypt -> Bool
$c<= :: BCrypt -> BCrypt -> Bool
< :: BCrypt -> BCrypt -> Bool
$c< :: BCrypt -> BCrypt -> Bool
compare :: BCrypt -> BCrypt -> Ordering
$ccompare :: BCrypt -> BCrypt -> Ordering
Ord, Value -> Parser [BCrypt]
Value -> Parser BCrypt
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BCrypt]
$cparseJSONList :: Value -> Parser [BCrypt]
parseJSON :: Value -> Parser BCrypt
$cparseJSON :: Value -> Parser BCrypt
A.FromJSON, [BCrypt] -> Encoding
[BCrypt] -> Value
BCrypt -> Encoding
BCrypt -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BCrypt] -> Encoding
$ctoEncodingList :: [BCrypt] -> Encoding
toJSONList :: [BCrypt] -> Value
$ctoJSONList :: [BCrypt] -> Value
toEncoding :: BCrypt -> Encoding
$ctoEncoding :: BCrypt -> Encoding
toJSON :: BCrypt -> Value
$ctoJSON :: BCrypt -> Value
A.ToJSON)

hashPassword :: T.Text -> IO BCrypt
hashPassword :: Text -> IO BCrypt
hashPassword Text
rawPassword = do
  Maybe ByteString
mPassword <- HashingPolicy -> ByteString -> IO (Maybe ByteString)
hashPasswordUsingPolicy HashingPolicy
policy (Text -> ByteString
TE.encodeUtf8 Text
rawPassword)
  forall (m :: * -> *) a. Monad m => a -> m a
return
    (Text -> BCrypt
BCrypt (ByteString -> Text
TE.decodeUtf8 (forall a. Partial => String -> Maybe a -> a
fromJustNote String
"Invalid hashing policy" Maybe ByteString
mPassword)))

validatePasswordHash :: BCrypt -> T.Text -> Bool
validatePasswordHash :: BCrypt -> Text -> Bool
validatePasswordHash BCrypt
hash' Text
pass = do
  ByteString -> ByteString -> Bool
validatePassword (Text -> ByteString
TE.encodeUtf8 (BCrypt -> Text
unBCrypt BCrypt
hash')) (Text -> ByteString
TE.encodeUtf8 Text
pass)

newtype ApiKey = ApiKey { ApiKey -> Text
unApiKey :: T.Text }

newtype HashedApiKey
  = HashedApiKey T.Text
  deriving stock (HashedApiKey -> HashedApiKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HashedApiKey -> HashedApiKey -> Bool
$c/= :: HashedApiKey -> HashedApiKey -> Bool
== :: HashedApiKey -> HashedApiKey -> Bool
$c== :: HashedApiKey -> HashedApiKey -> Bool
Eq, Eq HashedApiKey
HashedApiKey -> HashedApiKey -> Bool
HashedApiKey -> HashedApiKey -> Ordering
HashedApiKey -> HashedApiKey -> HashedApiKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HashedApiKey -> HashedApiKey -> HashedApiKey
$cmin :: HashedApiKey -> HashedApiKey -> HashedApiKey
max :: HashedApiKey -> HashedApiKey -> HashedApiKey
$cmax :: HashedApiKey -> HashedApiKey -> HashedApiKey
>= :: HashedApiKey -> HashedApiKey -> Bool
$c>= :: HashedApiKey -> HashedApiKey -> Bool
> :: HashedApiKey -> HashedApiKey -> Bool
$c> :: HashedApiKey -> HashedApiKey -> Bool
<= :: HashedApiKey -> HashedApiKey -> Bool
$c<= :: HashedApiKey -> HashedApiKey -> Bool
< :: HashedApiKey -> HashedApiKey -> Bool
$c< :: HashedApiKey -> HashedApiKey -> Bool
compare :: HashedApiKey -> HashedApiKey -> Ordering
$ccompare :: HashedApiKey -> HashedApiKey -> Ordering
Ord, Int -> HashedApiKey -> ShowS
[HashedApiKey] -> ShowS
HashedApiKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HashedApiKey] -> ShowS
$cshowList :: [HashedApiKey] -> ShowS
show :: HashedApiKey -> String
$cshow :: HashedApiKey -> String
showsPrec :: Int -> HashedApiKey -> ShowS
$cshowsPrec :: Int -> HashedApiKey -> ShowS
Show)
  deriving newtype (PersistValue -> Either Text HashedApiKey
HashedApiKey -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text HashedApiKey
$cfromPersistValue :: PersistValue -> Either Text HashedApiKey
toPersistValue :: HashedApiKey -> PersistValue
$ctoPersistValue :: HashedApiKey -> PersistValue
PersistField, PersistField HashedApiKey
Proxy HashedApiKey -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy HashedApiKey -> SqlType
$csqlType :: Proxy HashedApiKey -> SqlType
PersistFieldSql, Value -> Parser [HashedApiKey]
Value -> Parser HashedApiKey
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [HashedApiKey]
$cparseJSONList :: Value -> Parser [HashedApiKey]
parseJSON :: Value -> Parser HashedApiKey
$cparseJSON :: Value -> Parser HashedApiKey
A.FromJSON, [HashedApiKey] -> Encoding
[HashedApiKey] -> Value
HashedApiKey -> Encoding
HashedApiKey -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [HashedApiKey] -> Encoding
$ctoEncodingList :: [HashedApiKey] -> Encoding
toJSONList :: [HashedApiKey] -> Value
$ctoJSONList :: [HashedApiKey] -> Value
toEncoding :: HashedApiKey -> Encoding
$ctoEncoding :: HashedApiKey -> Encoding
toJSON :: HashedApiKey -> Value
$ctoJSON :: HashedApiKey -> Value
A.ToJSON)

generateApiKey :: IO ApiKey
generateApiKey :: IO ApiKey
generateApiKey = do
  ByteString
bytes <- Int -> IO ByteString
getEntropy Int
32
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ApiKey
ApiKey forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Base64Url.encodeBase64 ByteString
bytes

hashApiKey :: ApiKey -> HashedApiKey
hashApiKey :: ApiKey -> HashedApiKey
hashApiKey = Text -> HashedApiKey
HashedApiKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64Url.encodeBase64' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA256.hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiKey -> Text
unApiKey