[simple example of a site with a sessions and login/password
jeremy@n-heptane.com**20080620082630] addfile ./Logon.hs
addfile ./Makefile
addfile ./null.sh
adddir ./pages
addfile ./pages/Index.hs
addfile ./pages/Interface.hs
addfile ./pages/null.sh
hunk ./Logon.hs 1
+{-# OPTIONS_GHC -fth -fglasgow-exts -fallow-undecidable-instances #-}
+module Main where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Data.Generics hiding ((:+:))
+import Data.Maybe
+import System.Environment
+
+import HAppS.Data
+import HAppS.Data.IxSet
+import HAppS.State
+import HAppS.Server
+
+import Text.RJson
+
+import HAppS.Template.HSP
+import HAppS.Template.HSP.Handle
+import HAppS.Data.Session
+
+import Interface
+
+instance Component (Sessions SessionData) where
+ type Dependencies (Sessions SessionData) = End
+ initialValue = fromList []
+
+entryPoint :: Proxy (Sessions SessionData)
+entryPoint = Proxy
+
+main :: IO ()
+main =
+ do store <- newStore
+ control <- startSystemState entryPoint
+ eConf <- liftM parseConfig getArgs
+ let conf = case eConf of
+ Left e -> error (unlines e)
+ Right c -> c
+ tid <- forkIO $ simpleHTTP conf { validate = Just (smartValidate wdgValidate) } (impl store)
+ putStrLn "running..."
+ waitForTermination
+ killThread tid
+ shutdownSystem control
+
+impl store =
+ [ runHSPHandle "pages" "objfiles" store $
+ multi
+ [ dir "logon"
+ [ methodSP POST $
+ withDataFn (look "username") $ \usernm ->
+ [ anyRequest $
+ do sid <- newSession (SessionData { active=True, username=usernm })
+ addCookie (-1) (mkCookie "sessionId" (show sid))
+ seeOther "/" (toResponse ())
+ ]
+ ]
+ , withDataFn (readCookieValue "sessionId") $ \ sID ->
+ [ dir "logoff"
+ [ anyRequest $ do webUpdate (DelSession sID :: DelSession SessionData)
+ -- delCookie
+ seeOther "/" (toResponse ())
+ ]
+ , anyRequest $
+ do mSessData <- webQuery (GetSession sID)
+ case mSessData of
+ (Just (Session _ sessionData)) ->
+ addParam "session" (sessionData :: SessionData)
+ Nothing ->
+ addParam "session" (SessionData False "") -- expired session might be better
+ ok =<< execTemplate Nothing "Index.hs"
+ ]
+ , anyRequest $
+ do addParam "session" (SessionData False "")
+ ok =<< execTemplate Nothing "Index.hs"
+ ]
+ ]
+
+-- move to HAppS.Extra
+withSystemState action =
+ do control <- startSystemState entryPoint
+ action `finally` shutdownSystem control
+
+
+-- delete this function after HAppS-Server is rebuilt and exports it properly
+smartValidate :: (Response -> IO Response) -> Response -> IO Response
+smartValidate validator resp =
+ case rsValidate resp of
+ Nothing -> validator resp
+ (Just altValidator) -> altValidator resp
hunk ./Makefile 1
+test:
+ runhaskell -ipages Logon.hs --http-port=8000
+
+.PHONY: test
hunk ./null.sh 1
+#!/bin/sh
+cat $2 > $3
hunk ./pages/Index.hs 1
+{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-}
+module Index where
+
+import Control.Monad.Trans
+
+import HSP
+import HAppS.Template.HSP
+-- import HJScript
+-- import HJScript.DOM hiding (length)
+import Interface
+
+page :: Web XML
+page = withMetaData html4Strict $
+
+
+ Logon
+
+ <% logon %>
+
+
+logon :: Web XML
+logon =
+ do sd <- localRead "session"
+ if active sd
+ then
+ Hello, <% username sd %>
+ logoff
+
+ else
+ Logon
+
+
hunk ./pages/Interface.hs 1
-
+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}
+{-# OPTIONS_GHC -F -pgmF ./null.sh #-}
+module Interface where
+
+import HAppS.Data
+import Text.RJson
+
+$(deriveAll [''Eq, ''Ord, ''Read, ''Show]
+ [d|
+ data SessionData = SessionData { active :: Bool, username :: String }
+ |])
+
+$(deriveSerialize ''SessionData)
+instance Version SessionData
hunk ./pages/null.sh 1
+#!/bin/sh
+cat $2 > $3