happs-tutorial 0.0 → 0.1
raw patch · 8 files changed
+500/−16 lines, 8 filesdep ~HAppS-Datadep ~HAppS-Serverdep ~HAppS-State
Dependency ranges changed: HAppS-Data, HAppS-Server, HAppS-State, HStringTemplate, bytestring, containers, mtl
Files
- happs-tutorial.cabal +45/−16
- src/Controller.hs +53/−0
- src/ControllerBasic.hs +118/−0
- src/ControllerUsingTemplates.hs +42/−0
- src/Misc.hs +75/−0
- src/Model.hs +57/−0
- src/Session.hs +87/−0
- src/View.hs +23/−0
happs-tutorial.cabal view
@@ -1,16 +1,45 @@-name: happs-tutorial-version: 0.0-build-type: Simple-synopsis: A HAppS Tutorial that is is own demo-description: A nice way to learn how to build web sites with HAppS-category: Web-license: BSD3-license-file: LICENSE-author: Thomas Hartman-maintainer: thomashartman1 at gmail dot com-build-Depends: base >= 3, HStringTemplate >= 0.3.1, mtl >= 1.1.0.1, bytestring >= 0.9.0.1.1,- HAppS-Server >= 0.9.2.1, HAppS-Data >= 0.9.2.1, HAppS-State >= 0.9.2.1,- containers >= 0.1.0.2-executable: happs-tutorial-main-is: Main.hs-Hs-source-dirs: src+Name: happs-tutorial+Version: 0.1+Synopsis: A HAppS Tutorial that is is own demo+Description: A nice way to learn how to build web sites with HAppS++++License: BSD3+License-file: LICENSE+Author: Thomas Hartman+++++Maintainer: thomashartman1 at gmail dot com+Copyright: 2008 Thomas Hartman+++++Stability: Experimental+Category: Web+Build-type: Simple++Cabal-Version: >= 1.2++Executable happs-tutorial+ Main-is: Main.hs+ hs-source-dirs:+ src+ Other-Modules:+ ControllerBasic+ ControllerUsingTemplates + Misc + View+ Controller + Model + Session+ + Build-Depends: base >= 3, HStringTemplate, mtl, bytestring,+ HAppS-Server, HAppS-Data, HAppS-State,+ containers+++
+ src/Controller.hs view
@@ -0,0 +1,53 @@+module Controller where++import Control.Monad+import Control.Monad.Trans++import HAppS.Server+import Text.StringTemplate++import Misc+import Session+import View++import Model+import ControllerBasic+import ControllerUsingTemplates++-----controller+-- Web server functions+-- SPs: ServerParts+controller :: [ServerPartT IO Response]+controller = debugFilter $+ tutorial ++ loginHandlers ++ simpleHandlers ++ usingTemplatesHandlers ++ staticfiles+++loginHandlers = [+ dir "login" loginSPs+ , dir "newuser" [methodSP POST $ withData newUserPage]+ , dir "view" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) viewPage]+ , dir "list" userListPage ]++loginSPs = [methodSP GET $ ( ioMsgToSp . withBaseTemplateW [] ) "login" + , methodSP POST $ withData loginPage ]++-- serve arbitrary io actions: read files, fetch from database +helloworldio = [ ioMsgToSp iovalue ] + where iovalue :: IO HtmlString+ iovalue = (return . HtmlString ) "hello<br>world"++staticfiles = [ fileservedir "src" + , fileservedir "static" ] ++fileservedir d = dir d [ fileServe [] d ]++templateservedir d = dir d [ templateserve ]+templateserve = ServerPartT $ \rq -> case rqPaths rq of+ [tmpl] -> ( ioMsgToWeb . withBaseTemplateW [] ) tmpl+ _ -> noHandle ++tutorial = [+ exactdir "/" [ ioMsgToSp $ withBaseTemplateW [] "home" ]+ , dir "tutorial" [ templateserve ]+ ] +
+ src/ControllerBasic.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS -XPatternSignatures #-}+module ControllerBasic where ++import HAppS.Server+import Misc+import Data.Monoid++{-+ServerPartTs take a request to a response, approximately like so+Request -> WebT -> Result -> Response++Request handlers are functions from a request to a WebT, WebT is a wrapper over a Result,+and a Response is extracted from a Result by monadic machinery which you don't need +to understand for now.++A HAppS Server is generally a list of ServerPartTs. When the wrapped functions are run,+either they result in NoHandle or a valid response. If there's a valid response, it gets +displayed. If NoHandle, control is passed to the next ServerPartT/handler in the list.+If all the handlers produce NoHandle as a result, the result is a 404.++ServerPartT :: (Request -> WebT m a) -> ServerPartT m a+WebT :: m (Result a) -> WebT m a+data Result a+ = NoHandle | Ok (Response -> Response) a | Escape Response++-}++-- For everything below, the m monad is always IO and a result type is always Response,+-- so nail down types with more precision, which I have found helps with debugging+-- and understanding what's going on.+type TutHandler = ServerPartT IO Response+type TutWebT = WebT IO Response+++simpleHandlers :: [ServerPartT IO Response]+simpleHandlers = debugFilter [++ ServerPartT $ \rq -> do+ ru <- (return . rqURL) rq+ if ru == "/helloworld"+ then ( return . toResponse ) "hello world, this is HAppS" + else noHandle+ :: TutWebT+ + -- exactdir :: (Monad m) => String -> [ServerPartT m a] -> ServerPartT m a+ -- given a url path (for the part of the path after the domain) and a list of handlers+ -- exactdir runs the handlers against the request if the request url matches the first argument.++ -- msgToSp creates a handler that will return a constant response for any request.+ -- it is useful in conjunction with exactdir and other ServerPartT constructors.++ -- argument is an exact url path.+ -- so first arg is preceded by a /.+ -- you can use exactdir "" to match the root path+ , exactdir "/exactdir-with-msgtosp" [ msgToSp "this handler uses exactdir and msgToSp. subdirectories not allowed." ]++ -- argument is a string, which matches the first element of the rqURL path.+ -- pops the rqURL array, and passes the modified request to the list of handlers.+ -- e.g., if url is http://myapp.com/dir1/dir2/dir3+ -- the first element of the rqURL path is dir1.+ -- so first arg is not preceded by a /.+ -- you cannot use dir to match the root path.+ , dir "dir-with-msgtosp" [ msgToSp "this handler uses dir and msgToSp. subdirectories are allowed." ]++ -- ServerPartTs are monoids.+ -- instance (Monad m) => Monoid (ServerPartT m a)+ -- two handlers can be glued together into one handler with mappend,+ -- and a list of handlers can be glued with mconcat, + -- There is a "zero" or "empty" handler which results in a 404 page for any request.+ -- The way "handler addition" works is... for h1 `mappend` h2 ...+ -- if h1 rq is anything other than NoHandle, return that.+ -- if it is noHandle, return h2 rq+ , mappend ( exactdir "/handleraddition1" [msgToSp "handleraddition 1"] )+ ( exactdir "/handleraddition2" [msgToSp "handleraddition 2"] )++ -- more of same+ , mconcat [ mempty -- the zero handler has no effect+ , exactdir "/handleraddition3" [msgToSp "handleraddition 3"]+ , exactdir "/handleraddition4" [msgToSp "handleraddition 4"]+ , exactdir "/handleraddition5" [msgToSp "handleraddition 5"]+ ] +++ -- zero handler using mempty from the monoid instance, and the same thing again spelled out explicitly+ , exactdir "/nohandle1" [mempty] + , exactdir "/nohandle2" [ ServerPartT $ \rq -> WebT $ return NoHandle ] ++ , exactdir "/exactdirAndmsgToSp/anotherResponse"+ [ msgToSp "Another response generated using exactdir and msgToSp"] ++ , (exactdir "/ioaction"+ [ ioMsgToSp (return "This is an IO value.\+ \It could just as easily be the result of a file read operation,\+ \or a database lookup." :: IO String) ] )++ , (exactdir "/ioaction2"+ [ ioMsgToSp $ do slurp <- readFile "src/Main.hs"+ return $ "Let's try reading the Main.hs file: .....\n" ++ slurp ])++ , (exactdir "/htmlAttemptWrong"+ [msgToSp "first try at displaying <font color=\"red\">red formatted</font> html (wrong)"])+ , (exactdir "/htmlAttemptRight"+ [ ( msgToSp . HtmlString ) "second attempt at displaying <font color=\"red\">red formatted</font> html (right)"])++ , dir "templates" [fileServe [] "templates"]++ , dir "dirdemo" [ msgToSp "dir match. subpages will work" ]++ ]++-- pretty much useless little server part constructor, for demo purposes+simplematch :: String -> TutHandler+simplematch u = ServerPartT $ \rq -> do+ ru <- (return . rqURL) rq+ if ru == ("/simplematch" ++ u)+ then ( return . toResponse ) ( "matched " ++ u) + else noHandle :: TutWebT +
+ src/ControllerUsingTemplates.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS -XPatternSignatures #-}+module ControllerUsingTemplates where ++import HAppS.Server+import Misc+import Data.Monoid++import View+import Text.StringTemplate+++usingTemplatesHandlers :: [ServerPartT IO Response]+usingTemplatesHandlers = debugFilter [+ dir "usingtemplates"+ [ exactdir "/testtgio"+ [ ioMsgToSp ( withTutTemplate $ renderDef [("favoriteAnimal", "giraffe")] "myhomepage" ) ]+ ]+ ]++++++-- generate some html, from templates in templates directory+{-+generatePages = do+++ -- should probably change this to directoryGroup or directoryGroupLazy in production code+ -- but not sure which one is better... figure it out later.+ (tg :: STGroup String) <- unsafeVolatileDirectoryGroup "templates" 1 -- 1 second reload time++ (writeFile "myHomepage.html" . genMyHomepage) tg+ (writeFile "moreFavoriteAnimals.html" . genMoreFavoriteAnimals) tg+ where + genMyHomepage = toString . setAttribute "favoriteAnimal" "giraffe" . (getStringTemplateDef "myhomepage")+ genMoreFavoriteAnimals = toString + . optInsertTmpl [("separator","<p>\n")]+ . setAttribute "favoriteAnimals" favoriteAnimals + . getStringTemplateDef "moreFavoriteAnimals"+ favoriteAnimals = ["guppies","mayflies","dinosaurs"]+-}
+ src/Misc.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-}+module Misc where ++import HAppS.Server +import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Control.Monad.Trans+import Data.List+import Debug.Trace+import Text.StringTemplate+import Data.Monoid++newtype HtmlString = HtmlString String+instance ToMessage HtmlString where+ toContentType _ = B.pack "text/html"+ toMessage (HtmlString s) = L.pack s ++instance ToMessage (StringTemplate String) where+ toContentType _ = B.pack "text/html"+ toMessage = L.pack . toString ++{- +exactdir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a+exactdir staticPath handlers+ = ServerPartT $ \rq -> if ( \rq' -> ( rqURL rq' == staticPath ) ) rq+ then (\rq' -> unServerPartT (mconcat handlers) rq') rq+ else mempty+-}+exactdir staticPath = spCatIf rqmatch+ where rqmatch rq = rqURL rq == staticPath++-- concat handlers if...+spCatIf rqmatch handlers = ServerPartT h+ where h rq = if rqmatch rq then unServerPartT (mconcat handlers) rq else mempty++traceTrue x = trace (show x) True+++msgToWeb :: (Monad m, ToMessage a) => a -> WebT m Response+msgToWeb = return . toResponse++ioMsgToWeb :: (ToMessage a) => IO a -> WebT IO Response+ioMsgToWeb ios = liftIO $ do s <- ios+ ( return . toResponse ) s++msgToSp :: (Monad m, ToMessage a) => a -> ServerPartT m Response+msgToSp = anyRequest . msgToWeb++ioMsgToSp :: (ToMessage a) => (IO a) -> ServerPartT IO Response+ioMsgToSp = anyRequest . ioMsgToWeb+traceIt x = trace (show x) x+traceMsg msg x = trace ( msg ++ (show x) ) x+++instance (Monad m) => Monoid (ServerPartT m a)+ where mempty = ServerPartT $ \rq -> noHandle+ mappend a b = ServerPartT $ \rq -> (unServerPartT a rq) `mappend` (unServerPartT b rq) +++instance (Monad m) => Monoid (WebT m a) where+ mempty = noHandle+ mappend a b = WebT $ do a' <- unWebT a+ case a' of+ NoHandle -> unWebT b+ _ -> return a'++renderDef :: [(String,String)] -> String -> STGroup String -> StringTemplate String+renderDef attrs tmplname grp =+ maybe ( error $ "template not found: " ++ tmplname )+ ( setManyAttrib attrs )+ ( getStringTemplate tmplname grp )++-- withTemplateDir :: String -> (STGroup String -> String) -> IO String+withTemplateDir tdir f = return . f =<< unsafeVolatileDirectoryGroup tdir 1+
+ src/Model.hs view
@@ -0,0 +1,57 @@+module Model where++import Control.Monad+import HAppS.State+import HAppS.Server+import Session+import Misc+import View++-------state+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")++entryPoint :: Proxy State+entryPoint = Proxy++-- handlers that affect state+loginPage (UserAuthInfo user pass) = [anyRequest $ do+ allowed <- query $ AuthUser user pass+ if allowed+ then performLogin user+ else msgToWeb "Incorrect password"+ ]++performLogin user = do+ key <- update $ NewSession (SessionData user)+ addCookie (-1) (mkCookie "sid" (show key))+ msgToWeb $ "UserAuthInfo: " ++ show (user)++checkAndAdd user pass = do+ exists <- query $ IsUser user+ if exists+ then msgToWeb $ "User already exists"+ else do+ update $ ( AddUser user $ User user pass )+ msgToWeb $ "User created."++viewPage (Just sid) = [anyRequest $ do+ ses <- query $ (GetSession $ sid)+ ( ( ioMsgToWeb . withBaseContentW ) $ "Cookie value: " ++ (maybe "not logged in" show (ses :: Maybe SessionData)) :: WebT IO Response)]+viewPage Nothing =+ [ msgToSp "Not logged in"]++newUserPage (NewUserInfo user pass1 pass2)+ | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)]+ | otherwise = [ msgToSp "Passwords did not match"]++userListPage :: [ServerPartT IO Response]+userListPage = [anyRequest $ do u <- query ListUsers+ ( ioMsgToWeb . withBaseContentW ) $ "Users: " ++ (show u)]+
+ src/Session.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,+ MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}++module Session where ++import qualified Data.Map as M+import Control.Monad+import Control.Monad.Reader+import Control.Monad.State (modify,put,get,gets)+import Data.Generics hiding ((:+:))+import HAppS.Server+import HAppS.State+import HAppS.Data++type SessionKey = Integer ++data SessionData = SessionData { + sesUser :: String+} deriving (Read,Show,Eq,Typeable,Data) ++data Sessions a = Sessions {unsession::M.Map SessionKey a} + deriving (Read,Show,Eq,Typeable,Data)+ +data State = State { + sessions :: Sessions SessionData, + users :: M.Map String User+} deriving (Show,Read,Typeable,Data) ++data User = User { + username :: String, + password :: String+} deriving (Show,Read,Typeable,Data) ++instance Version SessionData +instance Version (Sessions a) ++$(deriveSerialize ''SessionData) +$(deriveSerialize ''Sessions)++instance Version State +instance Version User++$(deriveSerialize ''User) +$(deriveSerialize ''State) ++instance Component State where + type Dependencies State = End + initialValue = State (Sessions M.empty) M.empty + +askUsers :: MonadReader State m => m (M.Map String User) +askUsers = return . users =<< ask++askSessions::MonadReader State m => m (Sessions SessionData) +askSessions = return . sessions =<< ask++modUsers f = modify (\s -> (State (sessions s) (f $ users s))) +modSessions f = modify (\s -> (State (f $ sessions s) (users s))) ++isUser name = liftM (M.member name) askUsers ++addUser name u = modUsers $ M.insert name u ++authUser name pass = do+ users <- askUsers+ return $ (Just pass) == liftM password (M.lookup name users)++listUsers :: MonadReader State m => m [String]+listUsers = liftM M.keys askUsers++setSession key u = do+ modSessions $ Sessions . (M.insert key u) . unsession+ return ()++newSession u = do+ key <- getRandom+ setSession key u+ return key++getSession::SessionKey -> Query State (Maybe SessionData)+getSession key = liftM ((M.lookup key) . unsession) askSessions++numSessions:: Proxy State -> Query State Int+numSessions = proxyQuery $ liftM (M.size . unsession) askSessions++$(mkMethods ''State ['addUser, 'authUser, 'isUser, 'listUsers, 'setSession, 'getSession, 'newSession, 'numSessions])+
+ src/View.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-}+module View where++import Text.StringTemplate+import Misc++getTutTemplates = unsafeVolatileDirectoryGroup "templates" 1 -- 1 second reload time++-- plug a base templatate with a string which is based on a template file+withBaseTemplateW :: [(String,String)] -> String -> IO (StringTemplate String)+withBaseTemplateW attrs contentTmpl = do+ content <- return . toString =<< renderTut attrs contentTmpl+ withBaseContentW content++-- plug a base template with a string+withBaseContentW :: String -> IO (StringTemplate String)+withBaseContentW content = renderTut [("contentarea",content)] "base"+ +renderTut :: [(String,String)] -> String -> IO ( StringTemplate String )+renderTut attrs tmpl = withTutTemplate ( renderDef attrs tmpl )++withTutTemplate :: (STGroup String -> a) -> IO a+withTutTemplate = withTemplateDir "templates"