haskweb/App/Login.hs

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