PureScript Run is fun

PasswordManager.purs

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