module App.Login ( Login(..) ) where import Control.Monad.State (gets) import Request import Template import Network.FastCGI import AppMonad (numVisited, App) import Database import Shared data Login = Login | Register instance RequestHandler Login where handle Login = do loginStatus <- isLoggedIn if loginStatus then alreadyLoggedIn else login handle Register = do loginStatus <- isLoggedIn if loginStatus then alreadyLoggedIn else register loginSucceeded :: App CGIResult loginSucceeded = do mayFrom <- getInput "from" case mayFrom of Just from -> redirect from Nothing -> render "logged_in" [ ("pagetitle", "Angemeldet") , ("kind", "jetzt") ] >>= output loginFailed :: App CGIResult loginFailed = do result <- render "login" [("pagetitle", "Anmelden"), ("errormsg", "Ungültige Anmeldedaten")] output result alreadyLoggedIn :: App CGIResult alreadyLoggedIn = do result <- render "logged_in" [ ("pagetitle", "Angemeldet") , ("kind", "bereits") ] output result login :: App CGIResult login = do mayLogin <- sequence <$> sequence [getInput "username", getInput "password"] case mayLogin of Just [username, password] -> validate username password <: loginSucceeded <-> loginFailed Nothing -> do result <- render "login" [ ("pagetitle", "Anmelden") , ("errormsg", "") ] output result register :: App CGIResult register = do mayRegister <- sequence <$> sequence [ getInput "username" , getInput "password" , getInput "confirm_password" ] case mayRegister of Just [username, password, password_confirm] | password /= password_confirm -> registerFailed "Passwörter stimmen nicht überein!" | otherwise -> isAvailable username <: goRegister username password <-> registerFailed "Benutername wird schon verwendet!" Nothing -> do res <- render "register" [ ("pagetitle", "Registrierung") , ("errormsg", "") ] output res goRegister :: Username -> Password -> App CGIResult goRegister username password = do addUser username password res <- render "registered" [("pagetitle", "Registrierung abgeschlossen")] output res registerFailed :: String -> App CGIResult registerFailed reason = do res <- render "register" [ ("pagetitle", "Registrierung") , ("errormsg", reason ) ] output res