[added roles and actual accounts
Jeremy Shaw <jeremy@seereason.com>**20091113032607
 Ignore-this: 88217193a4818cc29e321307bb7fcab5
] hunk ./Main.hs 67
-                                , admin      = False
+                                , role       = User
hunk ./State.hs 17
+import qualified Data.Map as Map
+import Data.Maybe
hunk ./State.hs 21
-import Data.Maybe
hunk ./State.hs 49
-
hunk ./State.hs 53
+              , accounts     = Map.fromList [("admin",     (Password (Salt "aoeu") (doHash (Salt "aoeu") "foobar"), Admin))
+                                            ,("moderator", (Password (Salt "asdf") (doHash (Salt "asdf") "barbaz"), Moderator))
+                                            ]
hunk ./State.hs 67
-
hunk ./State.hs 182
+data InvalidLogin = InvalidLogin
+      deriving (Eq, Ord, Read, Show, Data, Typeable)
+
+$(deriveNewData [''InvalidLogin])
+instance Version InvalidLogin
+$(deriveSerialize ''InvalidLogin)
+
+checkPasswordDB :: String -> String -> Query State (Either InvalidLogin Role)
+checkPasswordDB username passwordStr = 
+    do users <- accounts <$> ask
+       case Map.lookup username users of
+         (Just (password, role))
+             | checkPassword password passwordStr -> return (Right role)
+         _ -> return (Left InvalidLogin)
+
hunk ./State.hs 206
+            , 'checkPasswordDB
hunk ./State.hs 351
+
+data CheckPassword = CheckPassword String String
+
+instance API CheckPassword where
+    type ReturnType CheckPassword = Either InvalidLogin Role
+    invokeLocal (CheckPassword username password) = query (CheckPasswordDB username password)
hunk ./Types.hs 12
-import Happstack.Data.User.Password (PasswordHash)
+import Happstack.Data.User.Password (Password, PasswordHash)
hunk ./Types.hs 90
+
+data Role
+    = User
+    | Moderator
+    | Admin
+      deriving (Read, Show, Eq, Ord, Enum, Data, Typeable)
+
hunk ./Types.hs 103
+            , accounts     :: Map String (Password, Role)
hunk ./Types.hs 134
+instance Version Role
+$(deriveSerialize ''Role)
hunk ./Web.hs 67
+    | W_Moderator
hunk ./Web.hs 97
-isAdmin :: (Functor m, MonadConfig m) => m Bool
-isAdmin = admin <$> askConfig
-
hunk ./Web.hs 115
+    toURLS W_Moderator  =
+        showString "moderator/"
hunk ./Web.hs 158
+             (Just "moderator") ->
+                 do return $ Success $ W_Moderator
hunk ./Web.hs 178
+                      , pure W_Moderator
+                      , pure W_Admin
hunk ./Web.hs 190
-                     , admin      :: Bool
+                     , role       :: Role
hunk ./Web.hs 227
---                mediaJS <- mapM imageToggleJS media --  :: URLT WebURL m [HJScript ()]
---                liftIO $ print mediaJS
hunk ./Web.hs 240
-                <% formletPart "login" hereURL handleSuccess handleFailure' loginForm %>)
+                <% formletPart "login" hereURL handleSuccess handleFailure' (loginForm `checkM` verifyPassword) %>)
hunk ./Web.hs 242
-      handleSuccess (username, password) =
+      verifyPassword  (username, password) =
+          do r <- invoke Nothing (CheckPassword username password)
+             case r of
+               (Left InvalidLogin) -> return $ Failure ["Invalid Login"]
+               (Right role)        -> return $ Success role
+      handleSuccess role =
hunk ./Web.hs 251
-             destURL  <- authURL (appSecret config) (show i) dest
+             addCookie (-1) (mkCookie "role" (show role))
+             destURL  <- authURL (appSecret config) (show i) role dest
hunk ./Web.hs 255
+web here@W_Moderator =
+    do homeURL <- showURL $ W_Board (BoardName $ Text.pack "codez") Nothing
+       (ok . toResponse) =<< (unXMLGenT $ appTemplate "Super Secret Lair" () $
+                                     <div>
+                                     <p>You are in the moderator's lair.</p>
+                                      <p>Continue your adventure <a href=homeURL>here</a></p>
+                                     </div>)
hunk ./Web.hs 270
-addAuth :: String -> Maybe String -> URLT url m a -> URLT url m a
-addAuth appSecret Nothing = id
-addAuth appSecret (Just userSecret) =
+addAuth :: String -> Maybe String -> Role -> URLT url m a -> URLT url m a
+addAuth appSecret Nothing _ = id
+addAuth appSecret (Just userSecret) role =
hunk ./Web.hs 275
-                        authKey = sha1 (appSecret ++ userSecret ++ link)
+                        authKey = sha1 (appSecret ++ userSecret ++ show role ++ link)
hunk ./Web.hs 279
-authURL :: (Monad m, ShowURL m) => String -> String -> URL m -> m Link
-authURL  appSecret userSecret url =
+authURL :: (Monad m, ShowURL m) => String -> String -> Role -> URL m -> m Link
+authURL  appSecret userSecret role url =
hunk ./Web.hs 282
-       let authKey = sha1 (appSecret ++ userSecret ++ link)
+       let authKey = sha1 (appSecret ++ userSecret ++ show role ++ link)
hunk ./Web.hs 298
-       r <- getDataFn $ (,) <$> ((Just <$> look "auth") <|> pure Nothing) <*> lookCookieValue "secret"
+       r <- getDataFn $ (,,) <$> ((Just <$> look "auth") <|> pure Nothing) <*> lookCookieValue "secret" <*> readCookieValue "role"
hunk ./Web.hs 300
-         (Left e) -> web (authRewrite False url)
-         (Right (mAuth, userSecret)) -> 
+         (Left e) -> web (authRewrite User url)
+         (Right (mAuth, userSecret, role)) -> 
hunk ./Web.hs 303
-               Nothing -> web (authRewrite False url)
+               Nothing -> web (authRewrite User url)
hunk ./Web.hs 306
-                      let auth' = sha1 ((appSecret config) ++ userSecret ++ link)
+                      let auth' = sha1 ((appSecret config) ++ userSecret ++ show role ++ link)
hunk ./Web.hs 308
-                         then addAuth (appSecret config) (Just userSecret) $ 
-                              localConfig (\c -> c { admin = True}) (web (authRewrite True url))
+                         then addAuth (appSecret config) (Just userSecret) role $ 
+                              localConfig (\c -> c { role = role}) (web (authRewrite role url))
hunk ./Web.hs 312
-authRewrite False W_Admin = W_Login W_Admin
+authRewrite role W_Admin 
+    | role /= Admin = W_Login W_Admin
+authRewrite role W_Moderator 
+    | (role /= Admin) && (role /= Moderator) = W_Login W_Moderator
hunk ./Web.hs 413
-       login <- if admin config
-                   then do adminURL <- showURL W_Admin
-                           <span class="admin"><a href=adminURL>admin</a></span>
-                   else do loginURL <- showURL (W_Login here)
-                           <span class="admin"><a href=loginURL>login</a></span>
+       login <- case role config of
+                  User -> 
+                      do loginURL <- showURL (W_Login here)
+                         <span class="admin"><a href=loginURL>login</a></span>
+                  Moderator -> 
+                      do moderatorURL <- showURL W_Moderator
+                         <span class="admin"><a href=moderatorURL>moderator</a></span>
+                  Admin ->
+                      do adminURL <- showURL W_Admin
+                         <span class="admin"><a href=adminURL>admin</a></span>
hunk ./Web.hs 425
-       adminURL <- showURL W_Admin