elision-0.1.0.1: example/Main.hs

{-# LANGUAGE GADTs, TypeOperators #-}
module Main where

import Control.Arrow.Elision
import Data.Functor.Identity

--------------------------------------------------------------------------------
type User = String

type Pass = String

data AuthLevel
  = Unauthorized
  | GuestAccess
  | AdminAccess
  deriving (Show, Eq, Ord, Enum)

instance Monoid AuthLevel where
  mempty = Unauthorized
  mappend = max

data Tty a where
  ReadLine ::           Tty String
  PutLine  :: String -> Tty ()

data Auth a where
  Guest ::         Pass -> Auth AuthLevel
  Admin :: User -> Pass -> Auth AuthLevel

--------------------------------------------------------------------------------
readLine :: Elision Tty () String
readLine = initial ReadLine

putLine :: Elision Tty String ()
putLine = simple <<^ PutLine

guestAccess :: Elision Auth Pass AuthLevel
guestAccess = simple <<^ Guest

adminAccess :: Elision Auth (User,Pass) AuthLevel
adminAccess = simple <<^ uncurry Admin

anyAccess :: Elision Auth (User,Pass) AuthLevel
anyAccess = uncurry mappend ^<< adminAccess &&& (guestAccess <<^ snd)

--------------------------------------------------------------------------------
ttyIO :: Tty a -> IO a
ttyIO action =
  case action of
    ReadLine  -> getLine
    PutLine s -> putStrLn s

ttyPure :: String -> Tty a -> Identity a
ttyPure line action =
  case action of
    ReadLine  -> pure line
    PutLine _ -> pure ()

authPure :: Auth a -> Identity a
authPure credentials =
  case credentials of
    Guest password ->
      if password == "guest_password"
         then pure GuestAccess
         else pure Unauthorized

    Admin user password ->
      if (user,password) == ("admin", "admin_password")
         then pure AdminAccess
         else pure Unauthorized

authIO :: Auth a -> IO a
authIO = pure . runIdentity . authPure

--------------------------------------------------------------------------------
getCredentials :: Elision Tty () (User,Pass)
getCredentials =
  do putLine <~ "Enter your username (blank if guest)"
     user    <- readLine
     putLine <~ "Enter your password"
     pass    <- readLine
     pure (user,pass)

interactiveAuth :: Elision (Tty // Auth) () AuthLevel
interactiveAuth = anyAccess </ getCredentials

main :: IO ()
main =
  do auth <- complete' (ttyIO // authIO) interactiveAuth
     print auth