Login.hs

module Bein.Web.Pages.Login where

import Bein.Web.Commands
import Bein.Web.Pages.Common
import Bein.Web.Types
import Bein.Web.Elements
import Bein.Web.Authentication
import Happstack.Server hiding (method)

loginTitle :: String
loginTitle = "Bein - Login"

login :: BeinServerPart Response
login = page (Just loginTitle) HideNone loginBody (noHtml,noHtml)

loginBody :: (Html,Html) -> BeinFormPart (Html,Html) Html
loginBody (headerMsg,loginMsg) = do
  mconcatM [
    paragraphM << headerMsg,
    paragraphM =<<: [ html "Bein is a web-based shell for exploratory data analysis.  ",
                      html "Its source and documentation is available at ",
                     anchorM <! [href "http://github.com/madhadron/bein"] << "github"],
    formTo "go" tryLogin =<< mconcatM [
      paragraphM =<<: [ alignedLabelM "Username:", textfieldM "username" <!> [value "", size "25"], brM,
                        alignedLabelM "Password:", passwordM "password" <!> [value "", size "25"], brM,
                        submitM "signin" "Sign in" <!> [thestyle "text-align: right"], html loginMsg ]]]

tryLogin :: BeinServerPart (FormResponse (Html,Html))
tryLogin = withDataFn loginFields tryLogin'
    where tryLogin' :: (String,String) -> BeinServerPart (FormResponse (Html,Html))
          tryLogin' = ensureSession loginFailed loginSucceeded
  
loginFailed :: BeinServerPart (FormResponse (Html,Html))
loginFailed = return $ ContinuePage (noHtml,redParagraph "Invalid username or password.")

loginSucceeded :: BeinServerPart (FormResponse (Html,Html))
loginSucceeded = fullUrl "/" >>= \u -> return $ RedirectTo u
  
loginFields :: RqData (String,String)
loginFields = do
  u <- look "username"
  p <- look "password"
  return (u,p)

authenticated :: BeinServerPart Response -> BeinServerPart Response
authenticated act = getRequestUser >>= \u -> case u of
  Just user -> act `withUser` user
  Nothing -> fullUrl "/login" >>= \url -> seeOther url (toResponse "Redirecting...")