[more work on getting a first pass going
Jeremy Shaw <jeremy@seereason.com>**20110208205448
 Ignore-this: f5151836fb107a7be1b35b0b4dae5fa6
] hunk ./Pages/Login.hs 22
+import           Data.Set         (Set)
hunk ./Pages/Login.hs 26
-import Happstack.Server           (CookieLife(Session), Response, ServerMonad(..), FilterMonad(..), Happstack, addCookie, internalServerError, lookPairs, mkCookie, seeOther, toResponse)
+import Happstack.Server           (CookieLife(Session), Response, ServerMonad(..), FilterMonad(..), Happstack, ServerPartT, addCookie, internalServerError, lookPairs, mkCookie, seeOther, toResponse)
hunk ./Pages/Login.hs 29
--- import Pages.AppTemplate          (appTemplate, appTemplate')
--- import Pages.InternalServerError  (internalServerErrorPage)
--- import State.Profile              (AddIdentifier(..), AskProfileByAuthId(..), AskProfileByIdentifier(..), CreateProfile(..), SetAuthToken(..))
--- import Pages.FormPart             (formPart, fieldset, ol, li)
-import State.Auth                 -- (AuthId(..), CheckAuth(..), GenUserId(..), genAuthToken)
--- import StoryPrompts               (StoryForm, StoryPrompts, seeOtherURL)
--- import StoryPromptsURL            (StoryPromptsURL(..), AuthURL(..), OpenIdProvider(..))
-import System.Random              (randomRIO)
+import State.Auth
+import Pages.AppTemplate
+import Profile
+import ProfileURL
hunk ./Pages/Login.hs 35
--- import Types                      (AuthToken(..), Profile(userId))
hunk ./Pages/Login.hs 37
-import Web.Routes                 (ShowURL, showURL, URL)
+import Web.Routes                 (RouteT, ShowURL, showURL, URL)
hunk ./Pages/Login.hs 51
-identifierToAuthId :: Identifier -> m Response
+-- calling this will log you in as one or more AuthIds
+identifierToAuthId :: (Happstack m) => Identifier -> m (Set AuthId)
hunk ./Pages/Login.hs 54
-    do authIds <- query (IdentifierAuthId identifier)
-       case Set.size userIds of
-         0 -> do uid <- createNewProfile authId
-                 addAuthCookie uid
+    do authIds <- query (IdentifierAuthIds identifier)
+       addAuthCookie authIds
+       return authIds
+{-
+data R =
+       NowUser UserId
+       | PickAuth (Set AuthIds)
+-}
+
+{-
+data PickUser 
+    = Picked UserId
+    | NeedsPickin (Set UserId)
+  -}            
+
+pickUserId :: AuthId -> RouteT ProfileURL (ServerPartT IO) Response
+pickUserId aid =
+    do mUid <- query (AuthIdUserId aid)
+       case mUid of
+         Nothing ->
+             do profiles <- query (AuthIdProfiles aid)
+                case Set.size profiles of
+                  -- this probably should not happen ?
+                  0 -> do uid <- update (CreateNewProfile (Set.singleton aid))
+                          update (SetAuthIdUserId aid uid)
+                          return $ toResponse $ "logged in as " ++ show uid
+                  1 -> do let profile = head $ Set.toList profiles
+                          update (SetAuthIdUserId aid (userId profile))
+                          return $ toResponse $ "logged in as " ++ show (userId profile)
+--                  n -> do 
+
+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>
+                
+{-
+                   Nothing -> 
+                       do uid <- update (CreateNewProfile (Set.singleton aid))
+                          update (SetAuthIdUserId aid uid)
+                          return $ toResponse $ "logged in as " ++ show uid
+                   (Just uid) ->
+                       do 
+-}
+
+{-
+authIdsToUserId :: (Happstack m) => Set AuthIds -> m Response
+authIdsToUserId authIds =
+       case Set.size authIds of
+         0 -> do aid <- update GenAuthId
+                 uid <- update (CreateNewProfile (Set.singleton aid))
+                 update (SetAuthIdUserId aid uid)
hunk ./Pages/Login.hs 112
+         1 -> do let aid = (head $ Set.toList authIds)
+                 mUid <- query (AuthIdUserId aid)
+                 case mUid of
+                   Nothing ->  -- this probably should not happen ?
+                       do uid <- update (CreateNewProfile (Set.singleton aid))
+                          update (SetAuthIdUserId aid uid)
+                          return $ toResponse $ "logged in as " ++ show uid
+                   (Just uid) ->
+                       do 
+-}
+--         n -> do 
hunk ./Pages/Login.hs 124
+
+ -- here we have multiple auth ids to pick from. We need to show the user something. But that means stopping and generating a new page. but we will lose the Identifier then.
hunk ./Pages/Login.hs 127
-       
+
+
hunk ./Profile.hs 22
-import           Happstack.Data.IxSet (IxSet, inferIxSet, noCalcs)
+import           Happstack.Data.IxSet (IxSet, (@=), inferIxSet, noCalcs)
hunk ./Profile.hs 24
+import Types
hunk ./Profile.hs 27
-newtype UserId = UserId { unUserId :: Integer }
-      deriving (Eq, Ord, Read, Show, Data, Typeable)
-instance Version UserId
-$(deriveSerialize ''UserId)
-$(deriveNewData [''UserId])
-
-succUserId :: UserId -> UserId
-succUserId (UserId i) = UserId (succ i)
hunk ./Profile.hs 65
+-- return the UserId currently prefered by this AuthId
+--
+-- can be Nothing if no preference is set, even if there are possible UserIds
hunk ./Profile.hs 73
+-- return all the Profiles associated with this AuthId
+authIdProfiles :: AuthId -> Query ProfileState (Set Profile)
+authIdProfiles aid =
+    do ps@(ProfileState {..}) <- ask
+       return $ IxSet.toSet (profiles @= aid)
+
hunk ./Profile.hs 98
+                , 'authIdProfiles
hunk ./Profile.hs 105
-addAuthCookie :: (Happstack m) => AuthId -> m ()
+addAuthCookie :: (Happstack m) => (Set AuthId) -> m ()
addfile ./ProfileURL.hs
hunk ./ProfileURL.hs 1
+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances #-}
+module ProfileURL where
+
+import Control.Applicative ((<$>))
+import Control.Monad
+import Data.Data
+import Data.Typeable
+import Test.QuickCheck
+import Web.Routes
+import Happstack.Server
+import Web.Routes.Happstack
+import Web.Routes.MTL
+import Types
+
+instance Happstack (RouteT ProfileURL (ServerPartT IO))
+
+data ProfileURL
+    = P_SetPersonality UserId
+      deriving (Eq, Ord, Read, Show, Data, Typeable)
+
+instance Arbitrary ProfileURL where
+    arbitrary = oneof $ [ P_SetPersonality . UserId <$> arbitrary
+                        ]
+
+
+instance PathInfo ProfileURL where
+    toPathSegments (P_SetPersonality userId) = "set_personality" : toPathSegments userId
+
+    fromPathSegments =
+        msum [ do segment "set_personality"
+                  userId <- fromPathSegments
+                  return (P_SetPersonality userId)
+             ]
+
+authUrlInverse :: Property
+authUrlInverse =
+    property (pathInfoInverse_prop :: ProfileURL -> Bool)
hunk ./State/Auth.hs 23
-    , AddAuthIdentifier
-    , RemoveAuthIdentifier
-    , IdentifierAuthIds
-    , AddAuthUserPassId
-    , RemoveAuthUserPassId
-    , UserPassIdAuthIds
+    , AddAuthIdentifier(..)
+    , RemoveAuthIdentifier(..)
+    , IdentifierAuthIds(..)
+    , AddAuthUserPassId(..)
+    , RemoveAuthUserPassId(..)
+    , UserPassIdAuthIds(..)
hunk ./State/Auth.hs 66
-
hunk ./State/Auth.hs 68
-                           , tokenAuthId  :: AuthId
+                           , tokenAuthId  :: Set AuthId
hunk ./State/Auth.hs 114
-{-
-data AuthIdentifier
-    = AuthIdentifier { aiIdentifier :: Identifier
-                     , aiAuthId       :: AuthId
-                     }
-    deriving (Eq, Ord, Read, Show, Data, Typeable)
-
-instance Version AuthIdentifier
-$(deriveSerialize ''AuthIdentifier)
-
-$(inferIxSet "AuthsIdentifier" ''AuthIdentifier 'noCalcs [''Identifier, ''AuthId])
--}
hunk ./State/Auth.hs 301
-       return $ (fmap tokenAuthId $ getOne $ authTokens @= tokenString)
+       case getOne $ authTokens @= tokenString of
+         Nothing -> return Nothing
+         (Just authToken) ->
+             case Set.size (tokenAuthId authToken) of
+               1 -> return (Just $ head $ Set.toList (tokenAuthId authToken))
+               _ -> return Nothing
+
+authTokenAuthIds :: String -> Query AuthState (Maybe (Set AuthId))
+authTokenAuthIds tokenString =
+    do as@(AuthState{..}) <- ask
+       case getOne $ authTokens @= tokenString of
+         Nothing -> return Nothing
+         (Just authToken) ->
+             return (Just $ tokenAuthId authToken)
hunk ./State/Auth.hs 321
-genAuthToken :: (MonadIO m) => AuthId -> Int -> m AuthToken
+genAuthToken :: (MonadIO m) => Set AuthId -> Int -> m AuthToken
hunk ./State/Auth.hs 326
-       return $ AuthToken { tokenString  = (show unAuthId) ++  random
+           prefix = case Set.toList aid of
+                            [] -> show "0"
+                            (a:_) -> show (unAuthId a)
+       return $ AuthToken { tokenString  = prefix ++ random 
hunk ./State/Auth.hs 396
+{-
+data AuthIdentifier
+    = AuthIdentifier { aiIdentifier :: Identifier
+                     , aiAuthId       :: AuthId
+                     }
+    deriving (Eq, Ord, Read, Show, Data, Typeable)
+
+instance Version AuthIdentifier
+$(deriveSerialize ''AuthIdentifier)
+
+$(inferIxSet "AuthsIdentifier" ''AuthIdentifier 'noCalcs [''Identifier, ''AuthId])
+-}
addfile ./Types.hs
hunk ./Types.hs 1
+{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable,
+    FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,
+    UndecidableInstances, TypeOperators, RecordWildCards
+    #-}
+module Types where
+
+import Control.Applicative
+import Data.Data
+import Happstack.Data
+import Happstack.Server
+import HSP
+import Web.Routes
+
+newtype UserId = UserId { unUserId :: Integer }
+      deriving (Eq, Ord, Read, Show, Data, Typeable)
+instance Version UserId
+$(deriveSerialize ''UserId)
+$(deriveNewData [''UserId])
+
+instance PathInfo UserId where
+    toPathSegments (UserId i) = toPathSegments i
+    fromPathSegments = UserId <$> fromPathSegments
+
+succUserId :: UserId -> UserId
+succUserId (UserId i) = UserId (succ i)
+
+instance EmbedAsAttr (RouteT url (ServerPartT IO)) (Attr String url) where
+    asAttr (n := u) = 
+        do url <- showURL u
+           asAttr $ MkAttr (toName n, pAttrVal url)
hunk ./demo.hs 19
-instance EmbedAsAttr (RouteT url (ServerPartT IO)) (Attr String url) where
-    asAttr (n := u) = 
-        do url <- showURL u
-           asAttr $ MkAttr (toName n, pAttrVal url)
-