{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules#-} module Web.Login where import Prelude hiding (div) import Text.Blaze.Html5 hiding (map, label, br) import Text.Blaze.Html5.Attributes hiding (dir, label) import qualified Text.Blaze.Html5 as H import Web.Routes.RouteT import Text.Blaze.Internal import Control.Monad.State import Control.Concurrent.STM import Language.Nomyx.Expression import Utils import Text.Reform.Happstack import Text.Reform import Debug.Trace.Helpers import Happstack.Server import Types import Multi --TODO to remove import Web.Common import Web.Settings import Web.Routes.Happstack() import Control.Applicative import Text.Reform.Blaze.String hiding (form) import Data.Text hiding (map, zip, concatMap) default (Integer, Double, Data.Text.Text) loginForm :: Maybe LoginPass -> NomyxForm LoginPass loginForm (Just (LoginPass login _)) = loginForm' login loginForm Nothing = loginForm' "" loginForm' :: String -> NomyxForm LoginPass loginForm' login = LoginPass <$> br ++> label "Please enter your login and password (if you don't have one, just invent it):" ++> br ++> br ++> label "Login: " ++> (inputText login) <*> label " Password: " ++> inputPassword <++ label " " loginPage :: RoutedNomyxServer Html loginPage = do link <- showURL PostLogin lf <- lift $ viewForm "user" $ loginForm Nothing mainPage (blazeForm lf link) "Login to Nomyx" "Login to Nomyx" True newPlayerPage :: LoginPass -> RoutedNomyxServer Html newPlayerPage lp = do link <- showURL $ NewPlayerLogin lp lf <- lift $ viewForm "user" $ loginForm (Just lp) mf <- lift $ viewForm "user" $ settingsForm Nothing mainPage (do lf ! (disabled "") H.br >> H.br "New Player? Welcome!" >> H.br (blazeForm mf link)) "Login to Nomyx" "New Player" True newPlayerLogin :: (TVar Multi) -> LoginPass -> RoutedNomyxServer Html newPlayerLogin tm (LoginPass login password) = do methodM POST liftRouteT $ lift $ putStrLn $ "newPlayerLogin" r <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing case r of (Right ms) -> do mpn <- evalCommand tm $ checkLoginWeb login password case mpn of LoginOK pn -> do link <- showURL $ Noop pn webCommand tm pn $ MultiMailSettings ms pn seeOther link $ string "Redirecting..." WrongPassword -> do link <- showURL $ Login seeOther link $ string "Redirecting..." NewLogin -> do pn <- evalCommand tm $ getNewPlayerNumber link <- showURL $ Noop pn webCommand tm pn $ MultiNewPlayer PlayerMulti { mPlayerNumber = pn, mPlayerName = login, mPassword = password, inGame = Nothing, mMail = defaultMailSettings, lastRule = Nothing} webCommand tm pn $ MultiMailSettings ms pn seeOther link $ string "Redirecting..." (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..." postLogin :: (TVar Multi) -> RoutedNomyxServer Html postLogin tm = do methodM POST r <- liftRouteT $ eitherForm environment "user" $ loginForm Nothing case r of (Right lp) -> checkLoginPassword lp tm (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..." checkLoginPassword :: LoginPass -> (TVar Multi) -> RoutedNomyxServer Html checkLoginPassword lp@(LoginPass login password) tm = do liftRouteT $ lift $ putStrLn $ "login:" ++ login liftRouteT $ lift $ putStrLn $ "password:" ++ password mpn <- evalCommand tm $ checkLoginWeb login password case mpn of LoginOK pn -> do link <- showURL $ Noop pn seeOther link $ string "Redirecting..." WrongPassword -> do link <- showURL $ Login seeOther link $ string "Redirecting..." NewLogin -> do link <- showURL $ NewPlayer lp seeOther link $ string "Redirecting..." data LoginResult = LoginOK PlayerNumber | WrongPassword | NewLogin checkLoginWeb :: PlayerName -> PlayerPassword -> State Multi LoginResult checkLoginWeb name pwd = do mpn <- findPlayer name case mpn of Just pl -> do traceM $ "Trying name:" ++ mPlayerName pl case pwd == mPassword pl of True -> do traceM "password OK" return $ LoginOK $ mPlayerNumber pl False -> do traceM "password false" return WrongPassword Nothing -> do traceM "New player" return NewLogin