UsingExceptT.hs

{-# LANGUAGE OverloadedStrings #-}

--
-- A working example of kqr's "A Gentle Introduction to Monad Transformers"
-- using ExceptT.
--
-- see https://github.com/kqr/gists/blob/master/articles/gentle-introduction-monad-transformers.md
--

import Data.Text
import Data.Text.IO as T
import Data.Map as Map
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)

data LoginError = InvalidEmail
                | NoSuchUser
                | WrongPassword

type LoginMonad a = ExceptT LoginError IO a

users :: Map Text Text
users = Map.fromList [("example.com", "qwerty123"), ("localhost", "password")]

main :: IO ()
main = do
  runExceptT loginDialogue
  return ()

loginDialogue :: LoginMonad ()
loginDialogue = do
  let retry = userLogin `catchE` wrongPasswordHandler
  token <- retry `catchE` printError
  liftIO $ T.putStrLn $ append "Logged in with token: " token

wrongPasswordHandler :: LoginError -> LoginMonad Text
wrongPasswordHandler WrongPassword = do
  liftIO $ T.putStrLn "Wrong password, one more chance."
  userLogin
wrongPasswordHandler err = throwE err

printError :: LoginError -> LoginMonad a
printError err = do
  liftIO . T.putStrLn $ case err of
    WrongPassword -> "Wrong password. No more chances"
    NoSuchUser -> "No user with that email exists."
    InvalidEmail -> "Invalid email address entered."
  throwE err

userLogin :: LoginMonad Text
userLogin = do
  token       <- getToken
  userpw      <- maybe (throwE NoSuchUser)
                    return (Map.lookup token users)
  password    <- liftIO $ T.putStrLn "Enter your password:" >> T.getLine

  if userpw == password
    then return token
    else throwE WrongPassword

getToken :: LoginMonad Text
getToken = do
  liftIO $ T.putStrLn "Enter email address:"
  input <- liftIO T.getLine
  ExceptT . return $ getDomain input

getDomain :: Text -> Either LoginError Text
getDomain email =
  case splitOn "@" email of
    [name, domain] -> Right domain
    _ -> Left InvalidEmail