Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
PureScript Run is fun
-- https://haskell-explained.gitlab.io/blog/posts/2019/07/28/polysemy-is-cool-part-1/
module PasswordManager where
import Prelude
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Node.Crypto.Hash (Algorithm(..), base64)
import Run (EFFECT, FProxy, Run, SProxy(..), Step(..), interpret, liftEffect, on, runAccumPure, send)
import Run as Run
newtype Username = Username String
newtype Password = Password String
newtype PasswordHash = PasswordHash String
data CryptoHashF a
= MakeHash Password (PasswordHash -> a)
| ValidateHash Password PasswordHash (Boolean -> a)
derive instance functorCryptoHashF :: Functor CryptoHashF
type CRYPTOHASH = FProxy CryptoHashF
_cryptohash = SProxy :: SProxy "cryptohash"
makeHash :: forall r. Password -> Run (cryptohash :: CRYPTOHASH | r) PasswordHash
makeHash p = Run.lift _cryptohash $ MakeHash p identity
validateHash :: forall r. Password -> PasswordHash -> Run (cryptohash :: CRYPTOHASH | r) Boolean
validateHash p hash = Run.lift _cryptohash $ ValidateHash p hash identity
---
data KVStoreF k v a
= LookupKV k (Maybe v -> a)
| UpdateKV k (Maybe v) a
derive instance functorKVStoreF :: Functor (KVStoreF k v)
type KVSTORE k v = FProxy (KVStoreF k v)
_kvstore = SProxy :: SProxy "kvstore"
lookupKV :: forall k v r. k -> Run (kvstore :: KVSTORE k v | r) (Maybe v)
lookupKV k = Run.lift _kvstore $ LookupKV k identity
writeKV :: forall k v r. k -> v -> Run (kvstore :: KVSTORE k v | r) Unit
writeKV k v = Run.lift _kvstore $ UpdateKV k (Just v) unit
deleteKV :: forall k v r. k -> Run (kvstore :: KVSTORE k v | r) Unit
deleteKV k = Run.lift _kvstore $ UpdateKV k Nothing unit
---
addUser
:: forall r
. Username
-> Password
-> Run (cryptohash :: CRYPTOHASH, kvstore :: KVSTORE Username PasswordHash | r) Unit
addUser username password = do
hashedPassword <- makeHash password
writeKV username hashedPassword
validatePassword
:: forall r
. Username
-> Password
-> Run (cryptohash :: CRYPTOHASH, kvstore :: KVSTORE Username PasswordHash | r) Boolean
validatePassword username password = do
hashInStore <- lookupKV username
case hashInStore of
Just h -> validateHash password h
Nothing -> pure false
---
handleCryptoHash :: forall r. CryptoHashF ~> Run (effect :: EFFECT | r)
handleCryptoHash = case _ of
ValidateHash (Password p) (PasswordHash h) go -> do
hash <- liftEffect $ base64 SHA512 p
pure <<< go $ hash == h
MakeHash (Password p) go -> do
hash <- liftEffect $ base64 SHA512 p
pure <<< go $ PasswordHash hash
runCryptoHash
:: forall r
. Run (effect :: EFFECT, cryptohash :: CRYPTOHASH | r)
~> Run (effect :: EFFECT | r)
runCryptoHash = interpret (on _cryptohash handleCryptoHash send)
---
runKVStoreAccum
:: forall r a k v
. Ord k
=> Run (kvstore :: KVSTORE k v | r) a
-> Run r (Map k v)
runKVStoreAccum = runAccumPure
(\acc -> on _kvstore (Loop <<< handlePure acc) Done)
(\acc _ -> acc)
M.empty
where
handlePure acc = case _ of
LookupKV k cb -> Tuple acc (cb (M.lookup k acc))
UpdateKV k Nothing cb -> Tuple (M.delete k acc) cb
UpdateKV k (Just v) cb -> Tuple (M.insert k v acc) cb
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment