[more refactoring to split the HSP stuff out of the core stuff
Jeremy Shaw <jeremy@seereason.com>**20110301183413
 Ignore-this: f14e62fec02e5a0a610eda579f4bb9e
] hunk ./AuthURL.hs 75
-    | A_Local
hunk ./AuthURL.hs 77
+    | A_Local
hunk ./Pages/Login.hs 4
-{-
-    ( googlePage
-    , openIdPage
-    )
-    ( genericOpenIdPage
-    , googlePage
-    , liveJournalPage
-    , loginPage
-    , localLoginPage
-    , myspacePage
-    , openIdPage
-    , yahooPage
-    ) 
--}
+
hunk ./Pages/Login.hs 15
+import Happstack.Server.HSP.HTML  (XML)
hunk ./Pages/Login.hs 17
-import HSP                        (Attr(..), EmbedAsAttr(..), EmbedAsChild(..), XMLGenT, genElement)
+import HSP                        (Attr(..), EmbedAsAttr(..), EmbedAsChild(..), XMLGenT, genElement, unXMLGenT)
+import HSP.ServerPartT()
hunk ./Pages/Login.hs 25
+import Types (UserId(..))
hunk ./Pages/Login.hs 33
-loginPage :: RouteT AuthURL (ServerPartT IO) Response
+loginPage :: XMLGenT (RouteT AuthURL (ServerPartT IO)) XML
hunk ./Pages/Login.hs 35
-    appTemplate "login" () $
hunk ./Pages/Login.hs 43
-addAuthPage :: RouteT AuthURL (ServerPartT IO) Response
+addAuthPage :: XMLGenT (RouteT AuthURL (ServerPartT IO)) XML
hunk ./Pages/Login.hs 45
-    appTemplate "login" () $
hunk ./Pages/Login.hs 53
+
+authPicker :: Set AuthId -> RouteT ProfileURL (ServerPartT IO) Response
+authPicker authIds =
+    appTemplate "Pick An Auth" ()
+                <div>
+                 <ul><% mapM auth (Set.toList authIds) %></ul>
+                </div>
+    where
+      auth authId =
+          <li><a href=(P_SetAuthId authId)><% show authId %></a></li> -- FIXME: give a more informative view. 
+
+personalityPicker :: Set Profile -> RouteT ProfileURL (ServerPartT IO) Response
+personalityPicker profiles =
+    appTemplate "Pick A Personality" ()
+                <div>
+                 <ul><% mapM personality (Set.toList profiles) %></ul>
+                </div>
+    where
+      personality profile =
+          <li><a href=(P_SetPersonality (userId profile))><% nickName profile %></a></li>
+
hunk ./Pages/Login.hs 137
-pickAuthId :: RouteT ProfileURL (ServerPartT IO) AuthId
+pickAuthId :: RouteT ProfileURL (ServerPartT IO) (Either (Set AuthId) AuthId)
hunk ./Pages/Login.hs 141
-         (Just authId) -> return authId
+         (Just authId) -> return (Right authId)
hunk ./Pages/Login.hs 147
-                          return authId
+                          return (Right authId)
hunk ./Pages/Login.hs 150
-                          return aid
-                  n -> escape $ authPicker authIds
+                          return (Right aid)
+                  n -> return (Left authIds)
hunk ./Pages/Login.hs 153
-authPicker :: Set AuthId -> RouteT ProfileURL (ServerPartT IO) Response
-authPicker authIds =
-    appTemplate "Pick An Auth" ()
-                <div>
-                 <ul><% mapM auth (Set.toList authIds) %></ul>
-                </div>
-    where
-      auth authId =
-          <li><a href=(P_SetAuthId authId)><% show authId %></a></li> -- FIXME: give a more informative view
-
-setAuthIdPage :: AuthId -> RouteT ProfileURL (ServerPartT IO) Response
+setAuthIdPage :: AuthId -> RouteT ProfileURL (ServerPartT IO) Bool
hunk ./Pages/Login.hs 162
-                           seeOther "/" (toResponse "") -- FIXME: don't hardcode destination
-                   else unauthorized =<< 
-                           appTemplate "unauthorized" ()
-                             <p>Attempted to set AuthId to <% show $ unAuthId authId %>, but failed because the Identifier is not associated with that AuthId.</p>
-
+                           return True
+                   else return False
hunk ./Pages/Login.hs 165
--- now that we have things narrowed down to a single 'AuthId', pick which personality we want to be
-pickProfile :: String -> RouteT ProfileURL (ServerPartT IO) Response
-pickProfile onLoginURL =
-    do aid <- pickAuthId
-       mUid <- query (AuthIdUserId aid)
-       case mUid of
-         Nothing ->
-             do profiles <- query (AuthIdProfiles aid)
-                case Set.size profiles of
-                  0 -> do uid <- update (CreateNewProfile (Set.singleton aid))
-                          update (SetAuthIdUserId aid uid)
-                          seeOther onLoginURL (toResponse onLoginURL)
-                  1 -> do let profile = head $ Set.toList profiles
-                          update (SetAuthIdUserId aid (userId profile))
-                          seeOther onLoginURL (toResponse onLoginURL)
-                  n -> do personalityPicker profiles
-         (Just uid) ->
-             seeOther onLoginURL (toResponse onLoginURL)
+data PickProfile 
+    = Picked UserId
+    | PickPersonality (Set Profile)
+    | PickAuthId      (Set AuthId)
hunk ./Pages/Login.hs 170
-personalityPicker :: Set Profile -> RouteT ProfileURL (ServerPartT IO) Response
-personalityPicker profiles =
-    appTemplate "Pick A Personality" ()
-                <div>
-                 <ul><% mapM personality (Set.toList profiles) %></ul>
-                </div>
-    where
-      personality profile =
-          <li><a href=(P_SetPersonality (userId profile))><% nickName profile %></a></li>
-                
+pickProfile :: RouteT ProfileURL (ServerPartT IO) PickProfile
+pickProfile =
+    do eAid <- pickAuthId
+       case eAid of
+         (Right aid) ->
+             do mUid <- query (AuthIdUserId aid)
+                case mUid of
+                  Nothing ->
+                      do profiles <- query (AuthIdProfiles aid)
+                         case Set.size profiles of
+                           0 -> do uid <- update (CreateNewProfile (Set.singleton aid))
+                                   update (SetAuthIdUserId aid uid)
+                                   return (Picked uid)
+--                                   seeOther onLoginURL (toResponse onLoginURL)
+                           1 -> do let profile = head $ Set.toList profiles
+                                   update (SetAuthIdUserId aid (userId profile))
+                                   return (Picked (userId profile))
+                           n -> do return (PickPersonality profiles)
+                  (Just uid) ->
+                      return (Picked uid)
+         (Left aids) -> return (PickAuthId aids)
hunk ./demo.hs 72
-    msum [ do r <- implSite_ baseURI "web/" spec
+    msum [ do r <- implSite_ baseURI "web/" (spec (Just "http://*.n-heptane.com:8000/"))
hunk ./demo.hs 81
-spec :: Site SiteURL (ServerPartT IO Response)
-spec = 
+spec :: Maybe String -> Site SiteURL (ServerPartT IO Response)
+spec realm = 
hunk ./demo.hs 84
-      Site { handleSite          = \f u -> unRouteT (handle u) f
+      Site { handleSite          = \f u -> unRouteT (handle realm u) f
hunk ./demo.hs 89
-handle :: SiteURL -> RouteT SiteURL (ServerPartT IO) Response
-handle url =
+handle :: Maybe String -> SiteURL -> RouteT SiteURL (ServerPartT IO) Response
+handle realm url =
hunk ./demo.hs 94
-                                nestURL U_Auth $ handleAuth onAuthURL auth
+                                nestURL U_Auth $ handleAuth realm onAuthURL auth
hunk ./demo.hs 97
-handleAuth :: String -> AuthURL -> RouteT AuthURL (ServerPartT IO) Response
-handleAuth onAuthURL url =
+handleAuth :: Maybe String -> String -> AuthURL -> RouteT AuthURL (ServerPartT IO) Response
+handleAuth realm onAuthURL url =
hunk ./demo.hs 100
-      A_Login                            -> loginPage
-      A_AddAuth                          -> addAuthPage
+      A_Login                            -> appTemplate "Login"    () loginPage
+      A_AddAuth                          -> appTemplate "Add Auth" () addAuthPage
hunk ./demo.hs 103
-      (A_OpenIdProvider authMode Google) -> googlePage authMode (Just "http://*.n-heptane.com:8000/") 
-      (A_OpenIdProvider authMode Yahoo)  -> yahooPage  authMode (Just "http://*.n-heptane.com:8000/") 
+      (A_OpenIdProvider authMode Google) -> googlePage authMode realm
+      (A_OpenIdProvider authMode Yahoo)  -> yahooPage  authMode realm
hunk ./demo.hs 110
-      P_PickProfile        -> pickProfile "/"
-      (P_SetAuthId authId) -> setAuthIdPage authId
+      P_PickProfile        -> 
+          do r <- pickProfile
+             case r of
+               (Picked {})                -> seeOther "/" (toResponse "/")
+               (PickPersonality profiles) -> personalityPicker profiles
+               (PickAuthId      authIds)  -> authPicker authIds
+                   
+                              
+      (P_SetAuthId authId) -> 
+          do b <- setAuthIdPage authId
+             if b
+              then seeOther "/" (toResponse "") -- FIXME: don't hardcode destination
+              else unauthorized =<< 
+                     appTemplate "unauthorized" ()
+                        <p>Attempted to set AuthId to <% show $ unAuthId authId %>, but failed because the Identifier is not associated with that AuthId.</p>
+