Last active
July 5, 2022 10:18
-
-
Save chshersh/e230558a42ee4142fb7303527c08298c to your computer and use it in GitHub Desktop.
CPS transformed code
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- Code for the following blog post: | |
-- https://kodimensional.dev/cps | |
{-# LANGUAGE LambdaCase #-} | |
module CPS where | |
data AppError | |
= UserSessionIsInvalid | |
| DbError InternalDbError | |
| UserAlreadyHasEmail | |
| UserHasDifferentEmail | |
| EmailIsTaken | |
data InternalDbError | |
data UserSession | |
data UserId | |
data Email = Email deriving Eq | |
data ID | |
validateUserSession :: UserSession -> IO (Maybe UserId) | |
validateUserSession = error "TODO: Not implemented" | |
getEmailByUserId :: UserId -> IO (Maybe Email) | |
getEmailByUserId = error "TODO: Not implemented" | |
getUserIdByEmail :: Email -> IO (Maybe UserId) | |
getUserIdByEmail = error "TODO: Not implemented" | |
insertUserEmail :: UserId -> Email -> IO (Either InternalDbError ID) | |
insertUserEmail = error "TODO: Not implemented" | |
withUserSession | |
:: UserSession | |
-> (UserId -> IO (Either AppError a)) | |
-> IO (Either AppError a) | |
withUserSession userSession next = validateUserSession userSession >>= \case | |
Nothing -> pure $ Left UserSessionIsInvalid | |
Just userId -> next userId | |
withCheckedUserEmail | |
:: UserId | |
-> IO (Either AppError a) | |
-> IO (Either AppError a) | |
withCheckedUserEmail userId email next = getEmailByUserId userId >>= \case | |
Just otherEmail | |
| email == otherEmail -> pure $ Left UserAlreadyHasEmail | |
| otherwise -> pure $ Left UserHasDifferentEmail | |
Nothing -> next | |
withCheckedOtherUserEmail | |
-> IO (Either AppError a) | |
-> IO (Either AppError a) | |
withCheckedOtherUserEmail email next = getUserIdByEmail email >>= \case | |
Just otherUserId -> pure $ Left EmailIsTaken | |
Nothing -> next | |
withEmailInsert | |
:: UserId | |
-> (ID -> IO (Either AppError a)) | |
-> IO (Either AppError a) | |
withEmailInsert userId email next = insertUserEmail userId email >>= \case | |
Left dbErr -> pure $ Left $ DbError dbErr | |
Right id' -> next id' | |
associateEmail | |
:: UserSession | |
-> IO (Either AppError ID) | |
associateEmail userSession email = | |
withUserSession userSession $ \userId -> | |
withCheckedUserEmail userId email $ | |
withCheckedOtherUserEmail email $ | |
withEmailInsert userId email $ \id' -> | |
pure $ Right id' |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment