hpaste

{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE TemplateHaskell , FlexibleInstances,
             UndecidableInstances, OverlappingInstances,
             MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

module Main where

import Control.Concurrent
import Control.Monad
import HAppS.Server
import HAppS.State

import Session --The session and state code already developed
impl = [ dir "login" [methodSP GET $ (fileServe ["login.html"] ".")
                     ,methodSP POST $ withData loginPage ]
       , dir "newuser" [methodSP POST $ withData newUserPage]
       , dir "view" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) viewPage]
       , dir "list" userListPage
       , anyRequest $ ok $ toResponse "Sorry, couldn't find a matching handler" ]
data UserAuthInfo = UserAuthInfo String String
data NewUserInfo = NewUserInfo String String String

instance FromData UserAuthInfo where
    fromData = liftM2 UserAuthInfo (look "username")
               (look "password" `mplus` return "nopassword")

instance FromData NewUserInfo where
    fromData = liftM3 NewUserInfo (look "username")
               (look "password" `mplus` return "nopassword")
               (look "password2" `mplus` return "nopassword2")
newUserPage (NewUserInfo user pass1 pass2)
  | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)]
  | otherwise = [anyRequest $ ok $ toResponse $ "Passwords did not match"]
checkAndAdd user pass = do
  exists <- query $ IsUser user
  if exists
    then ok $ toResponse $ "User already exists"
    else do
      update $ AddUser user $ User user pass
      ok $ toResponse $ "User created."
loginPage (UserAuthInfo user pass) = [anyRequest $ do
  allowed <- query $ AuthUser user pass
  if allowed
    then performLogin user
    else ok $ toResponse $ "Incorrect password"
  ]

performLogin user = do
  key <- update $ NewSession (SessionData user)
  addCookie (-1) (mkCookie "sid" (show key))
  ok $ toResponse $ "UserAuthInfo: " ++ show (user)
viewPage (Just sid) = [anyRequest $ do
  ses <- query $ (GetSession $ sid)
  ok $ toResponse $ "Cookie value: " ++ (maybe "not logged in" show (ses :: Maybe SessionData))]

viewPage Nothing =
  [anyRequest $ ok $ toResponse $ "Not logged in"]

userListPage = [anyRequest $ do u <- query ListUsers; ok $ toResponse $ "Users: " ++ (show u)]
entryPoint :: Proxy State
entryPoint = Proxy

main = do
  control <- startSystemState entryPoint
  tid <- forkIO $ simpleHTTP nullConf impl
  waitForTermination
  putStrLn "Shutting down..."
  killThread tid
  shutdownSystem control
  putStrLn "Shutdown complete"

{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE TemplateHaskell , FlexibleInstances,
             UndecidableInstances, OverlappingInstances,
             MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

module Main where

import Control.Concurrent
import Control.Monad
import HAppS.Server
import HAppS.State

import Session --The session and state code already developed
impl = [ dir "login" [methodSP GET $ (fileServe ["login.html"] ".")
                     ,methodSP POST $ withData loginPage ]
       , dir "logout" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) logoutPage]
       , dir "newuser" [methodSP POST $ withData newUserPage]
       , dir "deleteuser" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) deleteUserPage]
       , dir "view" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) viewPage]
       , dir "list" userListPage
       , anyRequest $ ok $ toResponse "Sorry, couldn't find a matching handler" ]
data UserAuthInfo = UserAuthInfo String String
data NewUserInfo = NewUserInfo String String String

instance FromData UserAuthInfo where
    fromData = liftM2 UserAuthInfo (look "username")
               (look "password" `mplus` return "nopassword")

instance FromData NewUserInfo where
    fromData = liftM3 NewUserInfo (look "username")
               (look "password" `mplus` return "nopassword")
               (look "password2" `mplus` return "nopassword2")
newUserPage (NewUserInfo user pass1 pass2)
  | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)]
  | otherwise = [anyRequest $ ok $ toResponse $ "Passwords did not match"]

checkAndAdd user pass = do
  exists <- query $ IsUser user
  if exists
    then ok $ toResponse $ "User already exists"
    else do
      update $ AddUser user $ User user pass
      ok $ toResponse $ "User created."

loginPage (UserAuthInfo user pass) = [anyRequest $ do
  allowed <- query $ AuthUser user pass
  if allowed
    then performLogin user
    else ok $ toResponse $ "Incorrect password"
  ]

performLogin user = do
  key <- update $ NewSession (SessionData user)
  addCookie (-1) (mkCookie "sid" (show key))
  ok $ toResponse $ "UserAuthInfo: " ++ show (user)

performLogout sid = update $ DelSession sid

logoutPage (Just sid)  = [anyRequest $ do                                                                                                                                
  loggedin <- query $ (IsSession $ sid)                                                                                                                                  
  if loggedin                                                                                                                                                            
    then do processLogout sid                                                                                                                                            
            ok $ toResponse $ "logged out."                                                                                                                              
    else                                                                                                                                                                 
        ok $ toResponse $ "not logged in"]         

logoutPage Nothing =                                                                                                                                                     
  [anyRequest $ ok $ toResponse $ "Not logged in"]

deleteUser (Just (SessionData s)) = do update $ DelUser s                                                                                                                
                                       return "deleted"
deleteUser Nothing = do return "nothing deleted"

deleteUserPage (Just sid) = [anyRequest $ do ses <- query $ (GetSession $ sid)                                                                                           
                                             performLogout sid                                                                                                           
                                             msg <- deleteUser ses                                                                                                       
                                             ok $ toResponse msg]                                                                                                        
deleteUserPage Nothing = [anyRequest $ ok $ toResponse "not logged in"]   

viewPage (Just sid) = [anyRequest $ do
  ses <- query $ (GetSession $ sid)
  ok $ toResponse $ "Cookie value: " ++ (maybe "not logged in" show (ses :: Maybe SessionData))]

viewPage Nothing =
  [anyRequest $ ok $ toResponse $ "Not logged in"]

userListPage = [anyRequest $ do u <- query ListUsers; ok $ toResponse $ "User

{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE TemplateHaskell , FlexibleInstances,
             UndecidableInstances, OverlappingInstances,
             MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

module Main where

import Control.Concurrent
import Control.Monad
import HAppS.Server
import HAppS.State

import Session --The session and state code already developed
impl = [ dir "login" [methodSP GET $ (fileServe ["login.html"] ".")
                     ,methodSP POST $ withData loginPage ]
       , dir "logout" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) logoutPage]
       , dir "newuser" [methodSP POST $ withData newUserPage]
       , dir "deleteuser" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) deleteUserPage]
       , dir "view" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) viewPage]
       , dir "list" userListPage
       , anyRequest $ ok $ toResponse "Sorry, couldn't find a matching handler" ]
data UserAuthInfo = UserAuthInfo String String
data NewUserInfo = NewUserInfo String String String

instance FromData UserAuthInfo where
    fromData = liftM2 UserAuthInfo (look "username")
               (look "password" `mplus` return "nopassword")

instance FromData NewUserInfo where
    fromData = liftM3 NewUserInfo (look "username")
               (look "password" `mplus` return "nopassword")
               (look "password2" `mplus` return "nopassword2")
newUserPage (NewUserInfo user pass1 pass2)
  | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)]
  | otherwise = [anyRequest $ ok $ toResponse $ "Passwords did not match"]

checkAndAdd user pass = do
  exists <- query $ IsUser user
  if exists
    then ok $ toResponse $ "User already exists"
    else do
      update $ AddUser user $ User user pass
      ok $ toResponse $ "User created."

loginPage (UserAuthInfo user pass) = [anyRequest $ do
  allowed <- query $ AuthUser user pass
  if allowed
    then performLogin user
    else ok $ toResponse $ "Incorrect password"
  ]

performLogin user = do
  key <- update $ NewSession (SessionData user)
  addCookie (-1) (mkCookie "sid" (show key))
  ok $ toResponse $ "UserAuthInfo: " ++ show (user)

performLogout sid = do                                                                                                                                                   
  addCookie 0 (mkCookie "sid" "0") -- delete cookie                                                                                                                      
  update $ DelSession sid

logoutPage (Just sid)  = [anyRequest $ do                                                                                                                                
  loggedin <- query $ (IsSession $ sid)                                                                                                                                  
  if loggedin                                                                                                                                                            
    then do processLogout sid                                                                                                                                            
            ok $ toResponse $ "logged out."                                                                                                                              
    else                                                                                                                                                                 
        ok $ toResponse $ "not logged in"]         

logoutPage Nothing =                                                                                                                                                     
  [anyRequest $ ok $ toResponse $ "Not logged in"]

deleteUser (Just (SessionData s)) = do update $ DelUser s                                                                                                                
                                       return "deleted"
deleteUser Nothing = do return "nothing deleted"

deleteUserPage (Just sid) = [anyRequest $ do ses <- query $ (GetSession $ sid)                                                                                           
                                             performLogout sid                                                                                                           
                                             msg <- deleteUser ses                                                                                                       
                                             ok $ toResponse msg]                                                                                                        
deleteUserPage Nothing = [anyRequest $ ok $ toResponse "not logged in"]   

view

Powered by HAppS. Copyright (c) 2007 glguy @ #haskell. Source via darcs.