[can now create and login using a local account. can't change password yet though.
Jeremy Shaw <jeremy@seereason.com>**20110325030156
 Ignore-this: 825f72d68eea821665a97cb3805ff4a5
] hunk ./Happstack/Auth/Core/Auth.hs 7
+    , UserPassId(..)
hunk ./Happstack/Auth/Core/Auth.hs 271
-checkUserPass :: Text -> Text -> Query AuthState (Either UserPassError (Set AuthId))
+checkUserPass :: Text -> Text -> Query AuthState (Either UserPassError UserPassId)
hunk ./Happstack/Auth/Core/Auth.hs 278
-                 do return (Right Set.empty)
+                 do return (Right (upId userPass))
hunk ./Happstack/Auth/Core/AuthParts.hs 54
-                 1 -> return $ (Just $ head $ Set.toList $ authIds)
-                 n -> return $ Nothing
+                1 -> return $ (Just $ head $ Set.toList $ authIds)
+                n -> return $ Nothing
hunk ./Happstack/Auth/Core/ProfileParts.hs 39
-         Nothing -> undefined
+         Nothing -> undefined -- FIXME
hunk ./Happstack/Auth/HSP/Login.hs 12
+import qualified Data.Text        as Text
hunk ./Happstack/Auth/HSP/Login.hs 23
-import HSP                        (Attr(..), EmbedAsAttr(..), EmbedAsChild(..), XMLGenT(..), XMLGenerator, genElement, unXMLGenT)
+import HSP                        (Attr(..), EmbedAsAttr(..), EmbedAsChild(..), XMLGenT(..), XMLGenerator, genElement, genEElement, unXMLGenT)
hunk ./Happstack/Auth/HSP/Login.hs 35
+
+
hunk ./Happstack/Auth/HSP/Login.hs 38
-logoutPage :: (XMLGenerator m, Alternative m, Happstack m, ShowURL m, URL m ~ AuthURL, EmbedAsAttr m (Attr String AuthURL)) => XMLGenT m (HSX.XML m)
+logoutPage :: (XMLGenerator m, Alternative m, Happstack m, EmbedAsAttr m (Attr String AuthURL)) => XMLGenT m (HSX.XML m)
hunk ./Happstack/Auth/HSP/Login.hs 52
+       <li><a href=A_Local                                 >Login</a> with a username and password.</li>
hunk ./Happstack/Auth/HSP/Login.hs 89
-
+{-
+providerPage :: (Happstack m, XMLGenerator m) => (forall body. (EmbedAsChild (RouteT AuthURL m) body) => (String -> () -> body -> XMLGenT (RouteT AuthURL m) Response)) -> OpenIdProvider -> AuthURL -> AuthMode -> RouteT AuthURL m Response
+-}
hunk ./Happstack/Auth/HSP/Login.hs 152
-
+{-
hunk ./Happstack/Auth/HSP/Login.hs 162
+-}
+
+handleAuth ::
+  (Happstack m, Alternative m) =>
+  (String  -> () -> XMLGenT (RouteT AuthURL m) XML -> RouteT AuthURL m Response)
+  -> Maybe String
+  -> String
+  -> AuthURL
+  -> RouteT AuthURL m Response
hunk ./Happstack/Auth/HSP/Login.hs 176
+      A_Local           -> localLoginPage appTemplate url onAuthURL
+      A_CreateAccount   -> createAccountPage appTemplate onAuthURL url
hunk ./Happstack/Auth/HSP/Login.hs 179
-      (A_OpenIdProvider authMode provider) ->  providerPage appTemplate provider url authMode
+      (A_OpenIdProvider authMode provider) 
+                        -> providerPage appTemplate provider url authMode
+
hunk ./Happstack/Auth/HSP/Login.hs 188
+              -> String
hunk ./Happstack/Auth/HSP/Login.hs 191
-handleProfile appTemplate url =
+handleProfile appTemplate postPickedURL url =
hunk ./Happstack/Auth/HSP/Login.hs 195
-             return undefined
hunk ./Happstack/Auth/HSP/Login.hs 197
-                   seeOther "/" (toResponse "/")
+                   seeOther postPickedURL (toResponse postPickedURL)
hunk ./Happstack/Auth/HSP/Login.hs 205
-
hunk ./Happstack/Auth/HSP/Login.hs 212
+{-
+localLoginPage :: (Happstack m, Alternative m) =>
+                 (forall header body. ( EmbedAsChild (RouteT AuthURL m) XML
+                                      , EmbedAsChild (RouteT AuthURL m) header
+                                      , EmbedAsChild (RouteT AuthURL m) body) => 
+                             (String  -> header -> body -> RouteT AuthURL m Response))
+              -> AuthURL
+              -> String
+              -> RouteT AuthURL m Response
+-}
+localLoginPage appTemplate here onAuthURL =
+    do actionURL <- showURL here
+       appTemplate "Login" () $
+         <div id="main">
+           <h1>Login with a username and password</h1>
+           <% formPart "p" actionURL (XMLGenT . handleLogin) (handleFailure appTemplate) loginForm %>
+        </div>
+
+      where 
+        handleLogin :: (Happstack m) => UserPassId -> RouteT AuthURL m Response
+        handleLogin userPassId =
+            do authId <- do authIds <- query (UserPassIdAuthIds userPassId) 
+                            case Set.size authIds of
+                              1 -> return (Just $ head $ Set.toList $ authIds)
+                              n -> return Nothing
+               addAuthCookie authId (AuthUserPassId userPassId)
+               seeOther onAuthURL (toResponse ())
+
+        loginForm :: (Functor v, MonadIO v, XMLGenerator m, EmbedAsAttr m (Attr String AuthURL)) => Form v Input String [XMLGenT m (HSX.XML m)] UserPassId
+        loginForm =
+            (errors ++> (fieldset $ ol (((,) <$> (li $ label "username: " ++> inputText Nothing) <*> (li $ label "password: " ++> inputPassword) <* login) `transform` checkAuth))) <* create
+
+        create :: (Functor v, Monad v, XMLGenerator m, EmbedAsAttr m (Attr String AuthURL)) => Form v Input String [XMLGenT m (HSX.XML m)] ()
+        create = view [<p>or <a href=(A_CreateAccount)>create a new account</a></p>]
+
+        login :: (Functor v, Monad v, XMLGenerator m) => Form v Input String [XMLGenT m (HSX.XML m)] String
+        login = li $ (submit "Login") `setAttrs` [("class" := "submit")]
+
+        checkAuth :: (MonadIO m) => Transformer m String (Text, String) UserPassId
+        checkAuth = 
+            transformEitherM $ \(username, password) ->
+                do r <- query (CheckUserPass username (Text.pack password))
+                   case r of 
+                     (Left e) -> return (Left $ userPassErrorString e)
+                     (Right userPassId) -> return (Right userPassId)
+
+        li :: a -> a
+        li = id
+             
+        ol :: a -> a
+        ol = id
+
+        fieldset :: a -> a
+        fieldset = id
+
+
+
+-- createAccountPage :: StoryPromptsURL -> StoryPrompts Response
+createAccountPage appTemplate onAuthURL here =
+    do actionURL <- showURL here
+       ok =<< appTemplate "Create User Account" () 
+          <div id="main">
+           <h1>Create an account</h1>
+           <% formPart "p" actionURL handleSuccess (handleFailure appTemplate) newAccountForm %>
+          </div>
+    where
+      handleSuccess (authId, userPassId) =
+          do addAuthCookie (Just authId) (AuthUserPassId userPassId)
+             seeOther onAuthURL (toResponse ())
+
+newAccountForm :: (Functor v, MonadIO v, XMLGenerator m, EmbedAsAttr m (Attr String AuthURL)) => Form v Input String [XMLGenT m (HSX.XML m)] (AuthId, UserPassId)
+newAccountForm =
+    fieldset (errors ++> (ol $ ((,) <$> username <*> password <* submitButton)
+                `transform`
+                createAccount))
+    where
+      br :: (XMLGenerator m, Monad v) => Form v Input String [XMLGenT m (HSX.XML m)] ()
+      br = view [<br />]
+      submitButton = li $ (submit "Create Account" `setAttrs` [("class" := "submit")])
+      username  = li $ ((label "username: "         ++> inputText Nothing)
+                   `validate` notEmpty) <++ errors
+      password1 = li $ label "password: "         ++> inputPassword
+      password2 = li $ label "confirm password: " ++> inputPassword
+--       password :: StoryForm String
+      password = 
+          errors ++> (minLengthString 6 $ 
+                      (((,) <$> password1 <*> password2) `transform` samePassword))
+
+      samePassword = 
+          transformEither $ \(p1, p2) ->
+              if p1 /= p2
+               then (Left "Passwords do not match.")
+               else (Right p1)
+
+--       createAccount :: (MonadIO m) => Transformer m String (Text, String) UserId
+      createAccount = 
+          transformEitherM $ \(username, password) ->
+              do passHash <- liftIO $ mkHashedPass (Text.pack password)
+                 r <- update $ CreateUserPass (UserName username) passHash
+                 -- fixme: race condition
+                 case r of
+                   (Left e) -> return (Left (userPassErrorString e))
+                   (Right userPass) -> 
+                       do authId <- update (NewAuthMethod (AuthUserPassId (upId userPass)))
+                          return (Right (authId, upId userPass))
+      li :: a -> a
+      li = id
+             
+      ol :: a -> a
+      ol = id
+
+      fieldset :: a -> a
+      fieldset = id
+
+      notEmpty :: (Monad m) => Validator m String Text
+      notEmpty = (check "field can not be empty") (not . Text.null)
+
+--       minLengthString :: Int -> StoryForm String -> StoryForm String
+      minLengthString 0 f = f
+      minLengthString 1 f = errors ++> (f `validate` (check "This field can not be empty." (not . null)))
+      minLengthString n f = errors ++> (f `validate` (check ("This field must be at least " ++ show n ++ " characters.") (\t -> length t >= n)))