happs-tutorial 0.4 → 0.4.1
raw patch · 10 files changed
+615/−7 lines, 10 files
Files
- happs-tutorial.cabal +17/−7
- src/ControllerGetActions.hs +167/−0
- src/ControllerMisc.hs +37/−0
- src/ControllerPostActions.hs +169/−0
- src/Debugging.hs +18/−0
- src/SerializeableSocialGraph.hs +39/−0
- src/StateStuff.hs +25/−0
- src/UniqueLabelsGraph.hs +81/−0
- src/ViewPagination.hs +55/−0
- src/ViewStuff.hs +7/−0
happs-tutorial.cabal view
@@ -1,5 +1,5 @@ Name: happs-tutorial-Version: 0.4+Version: 0.4.1 Synopsis: A HAppS Tutorial that is is own demo Description: A nice way to learn how to build web sites with HAppS @@ -93,14 +93,24 @@ hs-source-dirs: src Other-Modules:+ AppStateGraphBased+ AppStateSetBased ControllerBasic- Misc - View- Controller + ControllerGetActions+ Controller+ ControllerMisc+ ControllerPostActions+ Debugging+ Main+ Misc SerializeableSessions- SerializeableUsers - AppStateSetBased- AppStateGraphBased+ SerializeableSocialGraph+ SerializeableUsers+ StateStuff+ UniqueLabelsGraph+ View+ ViewPagination+ ViewStuff Build-Depends: base >= 3, HStringTemplate, mtl, bytestring, HAppS-Server, HAppS-Data, HAppS-State, containers, pretty, pureMD5, directory, filepath, hscolour, HTTP
+ src/ControllerGetActions.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE PatternSignatures, NoMonomorphismRestriction #-}+module ControllerGetActions where++import Control.Monad+import Control.Monad.Reader++import HAppS.Server++import ControllerMisc++import StateStuff+import ViewStuff+import Data.List+import qualified Data.Set as S++import Misc+++-- This could be a lot less verbose, and use shorter variable names,+-- but it's the tutorial instructional example for using FromData to deal with forms, so no harm.+data JobsPaginationUrlData = JobsPaginationUrlData { jpCurrPage :: Int, jpResultsPerPage :: Int }+instance FromData JobsPaginationUrlData where+ fromData =+ let readerCurrpage,readerResultsPerPage :: ReaderT ([(String, Input)], [(String, Cookie)]) Maybe Int+ readerCurrpage = return . read -- convert string to int+ =<< look "currentpage" `mplus` return "1" -- get string from urlencoded get string+ readerResultsPerPage = return . read =<< look "resultsPerPage" `mplus` return "10" ++ readerJobsPaginationUrlData :: ReaderT ([(String,Input)], [(String,Cookie)]) Maybe JobsPaginationUrlData+ readerJobsPaginationUrlData = liftM2 JobsPaginationUrlData readerCurrpage readerResultsPerPage+ in readerJobsPaginationUrlData +++--viewJobs :: RenderGlobals -> Pagination -> [ServerPartT IO Response]+viewJobs rglobs = withData $ \(JobsPaginationUrlData currP resPP) -> + [ ServerPartT $ \rq -> do + rsListAllJobs <- query ListAllJobs + let jobTable = paintAllJobsTable rglobs rsListAllJobs currP resPP+ -- if not logged in, you get invited to post a job,+ -- basically an incentive to register++ -- this next line should be coming from a template, and it's duplicated elsewhere, slightly bad.+ tmplattrs = maybe (def++[("postJob","post a HAppS job")]) (\_ -> def) (mbUser rglobs)+ where def = [("jobTable", jobTable)]+ return . tutlayoutU rglobs tmplattrs $ "jobs"+ ]++++data JobLookup = JobLookup {postedBy:: String, jobName :: String}+instance FromData JobLookup where+ fromData = liftM2 JobLookup (look "user")+ (look "job")+viewJob rglobs =+ withData $ \(JobLookup pBy jN) ->+ [ ServerPartT $ \rq -> do+ mbJ <- lookupJob pBy jN + case mbJ of+ Nothing -> return $ tutlayoutU rglobs [("errmsg", "no job found")] "errortemplate"+ Just j -> return $ tutlayoutU rglobs [("job",paintjob rglobs pBy j)] "viewjob"+ + ]++lookupJob pBy jN = do+ appUsers <- query AskDatastore+ return $ do u <- find ( (==pBy) . username) . S.toList $ appUsers+ find ( (==jN) . jobname) $ jobs u++++data UserNameUrlString = UserNameUrlString {profilename :: String}+instance FromData UserNameUrlString where+ fromData = liftM UserNameUrlString (look "user")++userProfile rglobs = + withData $ \(UserNameUrlString user) ->+ [ ServerPartT $ \rq -> do++ mbCP <- do mbU <- query (GetUser user) + return $ do u <- mbU+ return . consultantprofile $ u++ case mbCP of+ Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ user)] "viewconsultantprofile"+ Just cp -> return . tutlayoutU rglobs [("cp",paintProfile rglobs user cp)] $ "viewconsultantprofile"+ ]++++pageMyJobPosts rglobs = ServerPartT $ \rq -> do + let r = renderTemplateGroup (templates rglobs)+ case mbUser rglobs of+ Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"+ Just currU -> do+ let jobPostsTable = paintUserJobsTable rglobs (username currU) (jobs currU) 1 20+ return $ tutlayoutU rglobs [("jobPostsTable",jobPostsTable)] "myjobposts"++-- viewEditJob :: RenderGlobals -> ServerPartT IO Response +viewEditJobWD rglobs = withData $ \(JobLookup pBy jN) -> [viewEditJob pBy jN rglobs]+deleteJobWD rglobs = withData $ \(JobLookup pBy jN) -> [deleteJob pBy jN rglobs]++-- there's a lot of repeated code for viewEdit and Delete of jobs. +-- maybe can consolidate+deleteJob pBy jN rglobs = ServerPartT $ \rq -> do + case mbUser rglobs of+ Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"+ Just currU@(User n p cp js) -> do+ if (username currU) /= pBy+ then return $ tutlayoutU rglobs [("errormsg", "error: " ++ jN ++ " not posted by " ++ (username currU) )]+ "errortemplate"+ else do+ mbJ <- lookupJob pBy jN + case mbJ of+ Nothing -> return $ tutlayoutU rglobs+ [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"+ Just j -> do -- deleting a job by filtering a list seems wrong.+ -- probably should have used a Set rather than a list.+ -- but whatever, it works.+ let newjobs = filter (not . (==jN) . jobname) js+ newuser = User n p cp newjobs+ updateUserSp rglobs newuser pageMyJobPosts rq++viewEditJob pBy jN rglobs = ServerPartT $ \_ -> do + case mbUser rglobs of+ Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"+ Just currU -> do+ if (username currU) /= pBy+ then return $ tutlayoutU rglobs [("errormsg", "error: " ++ jN ++ " not posted by " ++ (username currU) )]+ "errortemplate"+ else do+ mbJ <- lookupJob pBy jN + case mbJ of+ Nothing -> return $ tutlayoutU rglobs+ [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"+ Just j -> do let -- use show below to properly escape quotes+ attrs = [ ("oldJobname", show . jobname $ j)+ , ("newJobname", show . jobname $ j)+ , ("budget", show . jobbudget $ j)+ , ("jobblurb", show . jobblurb $ j)+ , ("showJob",paintjob rglobs pBy j)+ ]+ return $ tutlayoutU rglobs attrs "editjob" ++++viewEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response +viewEditConsultantProfile rglobs = ServerPartT $ \rq -> do + case mbUser rglobs of+ Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"+ Just currU -> do+ let cp = consultantprofile currU + let showPr = paintProfile rglobs (username currU) cp + listAsConsultantChecked = if consultant cp+ then "checked"+ else ""+ -- use show below to properly escape quotes+ attrs = [ ("blurb", show . blurb $ cp)+ -- , ("jobsPosted",jobsPosted)+ , ("contact",show . contact $ cp)+ , ("listAsConsultantChecked", listAsConsultantChecked)+ , ("profile",showPr)+ ]+ return $ tutlayoutU rglobs attrs "editconsultantprofile"++++
+ src/ControllerMisc.hs view
@@ -0,0 +1,37 @@+module ControllerMisc where++import HAppS.Server++import Misc+import ViewStuff+import StateStuff++-- The final value is HtmlString so that the HAppS machinery does the right thing with toMessage.+-- If the final value was left as a String, the page would display as text, not html.+--tutlayoutReq :: Request -> [([Char], String)] -> String -> WebT IO Response+tutlayoutU rglobs attrs tmpl = ( toResponse . HtmlString . tutlayout rglobs attrs ) tmpl++-- getMbSessKey rq = readData (readCookieValue "sid") rq+getMbSessKey :: Request -> Maybe SessionKey+getMbSessKey rq = readData (readCookieValue "sid") rq++getmbLoggedInUser :: Request -> IO (Maybe String)+getmbLoggedInUser rq = do+ mbSd <- getMbSessData rq+ return $ do+ sd <- mbSd+ return . sesUser $ sd++getMbSessData :: Request -> IO (Maybe SessionData) +getMbSessData rq = do+ maybe ( return Nothing )+ ( query . GetSession )+ ( getMbSessKey rq )++-- updateUserSp :: RenderGlobals -> User -> User -> (RenderGlobals -> ServerPartT IO Response) -> WebT IO Response+updateUserSp rglobs newuser withrgSp rq = do+ case mbUser rglobs of+ Nothing -> return $ tutlayoutU rglobs [("errormsg", "updateUserSp: no user")] "errortemplate"+ Just olduser -> do update (UpdateUser olduser newuser)+ let newrglobs = RenderGlobals (templates rglobs) (Just newuser)+ unServerPartT ( withrgSp newrglobs ) rq
+ src/ControllerPostActions.hs view
@@ -0,0 +1,169 @@+module ControllerPostActions where++import Control.Monad+import Control.Monad.Trans++import HAppS.Server++import StateStuff+import ViewStuff++import Misc+import ControllerMisc+import ControllerGetActions++data UserAuthInfo = UserAuthInfo String String+instance FromData UserAuthInfo where+ fromData = liftM2 UserAuthInfo (look "username")+ (look "password" `mplus` return "nopassword")+loginPage rglobs =+ withData $ \(UserAuthInfo user pass) -> + [ ServerPartT $ \rq -> do+ mbUser <- authUser user pass++ case mbUser of + Nothing -> ( return . tutlayoutU rglobs [("errormsg","login error: invalid username or password")] ) "home"+ Just u -> startsess rglobs u+ + ]++data ChangeUserInfo = ChangeUserInfo String String String +instance FromData ChangeUserInfo where+ fromData = liftM3 ChangeUserInfo ( (look "oldpass") `mplus` (return "no old password") )+ (look "password" `mplus` return "no password")+ (look "password2" `mplus` return "no password2")++changePasswordSP rglobs = withData $ \(ChangeUserInfo oldpass newpass1 newpass2) -> [ ServerPartT $ \rq -> do+ if newpass1 == newpass2 + then do mbL <- liftIO $ getmbLoggedInUser rq+ maybe+ (errW "Not logged in" rq)+ (\u -> do mbU <- query (GetUser u)+ case mbU of+ Nothing -> errW ("bad username: " ++ u) rq + Just user -> do update $ ChangePassword user oldpass newpass1+ return $ tutlayoutU rglobs [] "accountsettings-changed" )+ mbL+ else errW "new passwords did not match" rq+ ]+ where errW msg rq = ( return . tutlayoutU rglobs [("errormsgAccountSettings", msg)] ) "changepassword" +++instance FromData ConsultantProfile where+ fromData = liftM3 ConsultantProfile ( (look "contact") `mplus` (return "") )+ (look "consultantblurb")+ --very, VERY hackish way of reading a checkbox+ ( return . not . (=="noval")+ =<< look "listasconsultant" `mplus` return "noval" )+ + ++-- should reuse auth code from change password+processformEditConsultantProfile rglobs =+ withData $ \fd@(ConsultantProfile pContact pBlurb listAsC) -> [ ServerPartT $ \rq -> do+ case (mbUser rglobs) of+ Nothing -> errW "Not logged in" rq+ Just olduser@(User uname p cp js) -> do+ let newuser = User uname p (ConsultantProfile pContact pBlurb listAsC) js+ updateUserSp rglobs newuser viewEditConsultantProfile rq+ ]+ where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"+++data EditJob = EditJob {oldjobname::String,jobtitle::String,jobbudget::String,jobdescription::String}++-- Recommendation: ALWAYS give a default value via mplus, otherwise debugging can be hell.+instance FromData EditJob where+ fromData = liftM4 EditJob (look "oldjobname" `mplus` return "bad old job name")+ (look "jobtitle" `mplus` return "bad job title")+ (look "jobbudget" `mplus` return "bad budget")+ (look "jobdescription" `mplus` return "bad job description")+++ +processformEditJob :: RenderGlobals -> ServerPartT IO Response+processformEditJob rglobs@(RenderGlobals ts mbU) =+ withData $ \(EditJob ojn jn jbud jblu) -> [ ServerPartT $ \rq -> do+ case mbU of+ Nothing -> errW "Not logged in" rq+ Just olduser@(User uname p cp js) -> do+ let -- update the jobs list with the new info+ -- it feels kludgy to use map, because it would seem that you could have jobs with duplicate names+ -- probably the jobs collection could be a set, maybe fix later. it's just a demo.+ newjob = Job jn jbud jblu+ newjobs = map f js+ where f j | jobname j == ojn = newjob+ | otherwise = j+ newuser = User uname p cp newjobs+ updateUserSp rglobs newuser (viewEditJob uname jn) rq++ ]+ where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"+++instance FromData Job where+ fromData = liftM3 Job (look "jobtitle" `mplus` return "bad job title")+ (look "jobbudget" `mplus` return "bad budget")+ (look "jobdescription" `mplus` return "bad job description")++processformNewJob rglobs@(RenderGlobals ts mbU) =+ withData $ \newjob@(Job n budget blurb) -> [ ServerPartT $ \rq -> do+ case mbU of+ Nothing -> errW "Not logged in" rq+ Just olduser@(User uname p cp js) -> do+ let newuser = User uname p cp (newjob:js)+ update (UpdateUser olduser newuser)+ let newrglobs = RenderGlobals ts (Just $ User uname p cp (newjob:js) )+ unServerPartT ( pageMyJobPosts newrglobs ) rq + ]+ where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"++data NewUserInfo = NewUserInfo String String String+instance FromData NewUserInfo where+ fromData = liftM3 NewUserInfo (look "username")+ (look "password" `mplus` return "nopassword")+ (look "password2" `mplus` return "nopassword2")+++-- newUserPage :: RenderGlobals -> ServerPartT IO Response+newUserPage rglobs =+ withData $ \(NewUserInfo user pass1 pass2) -> + [ ServerPartT $ \rq -> + if pass1 == pass2 + then do exists <- query $ IsUser user+ if exists+ then errW "User already exists" rq+ else do+ update $ ( AddUser user pass1 )+ mbU <- query (GetUser user)+ case mbU of+ Nothing -> errW "newUserPage, update failed" rq+ Just u -> startsess rglobs u+ else errW "passwords did not match" rq+ ]+ where errW msg rq = ( return . tutlayoutU rglobs [("errormsgRegister", msg)] ) "register" +++++-- check if a username and password is valid. If it is, return the user as successful monadic value+-- otherwise fail monadically+authUser :: Monad m => String -> String -> WebT IO (m User)+authUser name pass = do+ mbUser <- query (GetUser name)+ case mbUser of+ Nothing -> return . fail $ "login failed"+ (Just u) -> do+ p <- return . password $ u+ if p == (scramblepass pass)+ then return . return $ u+ else return . fail $ "login failed"++-- to do: make it so keeps your current page if you login/logout+-- probably modify RenderGlobals to keep track of that bit of state+startsess :: RenderGlobals -> User -> WebT IO Response+startsess (RenderGlobals ts _) user = do+ key <- update $ NewSession (SessionData $ username user)+ addCookie (3600) (mkCookie "sid" (show key))+ let newRGlobs = RenderGlobals ts (Just user) + (return . tutlayoutU newRGlobs [] ) "home"
+ src/Debugging.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++import HAppS.Server+import HAppS.State+import Misc+import Session +import SessionState++req1 :: Request+req1 = read "Request {rqMethod = GET, rqPaths = [], rqQuery = \"\", rqInputs = [], rqCookies = [], rqVersion = Version 1 1, rqHeaders = fromList [(\"accept\",HeaderPair {hName = \"accept\", hValue = [\"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\"]}),(\"accept-charset\",HeaderPair {hName = \"accept-charset\", hValue = [\"ISO-8859-1,utf-8;q=0.7,*;q=0.7\"]}),(\"accept-encoding\",HeaderPair {hName = \"accept-encoding\", hValue = [\"gzip,deflate\"]}),(\"accept-language\",HeaderPair {hName = \"accept-language\", hValue = [\"en-us,en;q=0.5\"]}),(\"connection\",HeaderPair {hName = \"connection\", hValue = [\"keep-alive\"]}),(\"host\",HeaderPair {hName = \"host\", hValue = [\"localhost:5001\"]}),(\"keep-alive\",HeaderPair {hName = \"keep-alive\", hValue = [\"300\"]}),(\"user-agent\",HeaderPair {hName = \"user-agent\", hValue = [\"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.16) Gecko/20080718 Ubuntu/8.04 (hardy) Firefox/2.0.0.16\"]})], rqBody = Body Empty, rqPeer = (\"localhost\",50453)}"++req2 = read "Request {rqMethod = GET, rqPaths = [\"start-happs-on-boot\"], rqQuery = \"\", rqInputs = [], rqCookies = [(\"sid\",Cookie {cookieVersion = \"\", cookiePath = \"\", cookieDomain = \"\", cookieName = \"sid\", cookieValue = \"-1184419469\"})], rqVersion = Version 1 1, rqHeaders = fromList [(\"accept\",HeaderPair {hName = \"accept\", hValue = [\"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\"]}),(\"accept-charset\",HeaderPair {hName = \"accept-charset\", hValue = [\"ISO-8859-1,utf-8;q=0.7,*;q=0.7\"]}),(\"accept-encoding\",HeaderPair {hName = \"accept-encoding\", hValue = [\"gzip,deflate\"]}),(\"accept-language\",HeaderPair {hName = \"accept-language\", hValue = [\"en-us,en;q=0.5\"]}),(\"connection\",HeaderPair {hName = \"connection\", hValue = [\"keep-alive\"]}),(\"cookie\",HeaderPair {hName = \"cookie\", hValue = [\"sid=\\\"-1184419469\\\"\"]}),(\"host\",HeaderPair {hName = \"host\", hValue = [\"localhost:5001\"]}),(\"keep-alive\",HeaderPair {hName = \"keep-alive\", hValue = [\"300\"]}),(\"referer\",HeaderPair {hName = \"referer\", hValue = [\"http://localhost:5001/tutorial/stringtemplate-basics\"]}),(\"user-agent\",HeaderPair {hName = \"user-agent\", hValue = [\"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.16) Gecko/20080718 Ubuntu/8.04 (hardy) Firefox/2.0.0.16\"]})], rqBody = Body Empty, rqPeer = (\"localhost\",42390)}"++t1 :: Maybe SessionKey+t1 = readData (readCookieValue "sid" ) req1++t2 :: Maybe SessionKey+t2 = readData (readCookieValue "sid" ) req2
+ src/SerializeableSocialGraph.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+module SerializeableSocialGraph where++import Data.Generics+import HAppS.State+++-- Don't import anything from Data.Graph.Inductive.+-- Export whatever you need in UniqueLabelsGraph+-- That way non-unique-label operating functions like mkGraph, insNode, etc are hidden+-- import UniqueLabelsGraph+++-- If your datatype is read/showable, you can use a deriving clause to get a serializeable+-- instance, as I do below.+-- However in the fgl, Gr isn't readable, which violates read/show invertability and probably+-- should be patched in the fgl at some point.+-- So I modified code from the fgl in the modules below, basically just to have a derived readable instance+import SerializeableTree +import SerializeableFiniteMap++import SerializeableUsers++-- There is Template Haskell machinery for deriving Serialize instances of many data types+-- , including Sets and Maps, in HAppS.Data.SerializeTH. +-- However, there was no machinery for deriving serializeable Graphs+-- So I declared an instance manually+instance Version (Gr a b) where mode = Primitive+instance (Serialize a,Serialize b, Eq a) => Serialize (Gr a b) where+ getCopy = contain ( fmap ( Gr . fmFromList ) safeGet )+ putCopy (Gr m) = contain . safePut . fmToList $ m+++data SocialGraph = SocialGraph { + socialgraph :: Gr User Float+} deriving (Read,Show,Eq, Typeable,Data) -- +instance Version SocialGraph+$(deriveSerialize ''SocialGraph) +
+ src/StateStuff.hs view
@@ -0,0 +1,25 @@+module StateStuff (++ module HAppS.State++ -- If you substitute AppStateGraphBased for AppStateSetBased, + -- , move _local ot _local.bak (backup your serialized state)+ -- , and restart app+ -- , your datastore is now graph based+ -- User nodes can connect to each other simply using mkEdge, or whatever else from the fgl.+ -- Now you can clone facebook.+ -- Try doing that with mysql! :)++ , module AppStateSetBased -- AppStateGraphBased -- ++ , module SerializeableUsers+ , module SerializeableSessions++ ) where++import HAppS.State++import AppStateSetBased -- AppStateGraphBased -- +import SerializeableUsers+import SerializeableSessions+
+ src/UniqueLabelsGraph.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module UniqueLabelsGraph (+ insUqNode, insUqNodes, mkUqGraph, lnodesetFromGraph, labelsetFromGraph, empty, matchLabel, labelExists,+ addLab, modLab,+ DynGraphUqL+)++where++import Data.Graph.Inductive+import Control.Monad.State+import Data.Maybe+import qualified Data.Set as S+import Data.List (foldl',find)++-- like insNode(s) from Data.Graph.Inductive, but only works if node label is unique+-- a class for graphs with unique labels+-- you get an error if you try to insert duplicate labels+-- and there's a function for returning all node labels as a set.+-- wouldn't Ord constraint be better?++-- minimum definition: insUqNode+class (Ord a, DynGraph gr) => DynGraphUqL a gr where+ insUqNode :: LNode a -> gr a b -> gr a b+ insUqNode (v,l) gr | found = error "insNode, duplicate Node " + | otherwise = insNode (v,l) gr+ where found = isJust . find (\(_,lab) -> lab==l) . labNodes $ gr+ matchLabel :: a -> gr a b -> (Maybe (Data.Graph.Inductive.Context a b), gr a b)+ matchLabel l g = + case filter ( (==l) . snd) . labNodes $ g of+ [] -> (Nothing,g)+ [(nodeI,_)] -> match nodeI g+ otherwise -> error "matchLabel, duplidate labels"++instance (Ord a, DynGraph gr) => DynGraphUqL a gr++insUqNodes vs g = foldr insUqNode g vs++lnodesetFromGraph g = S.fromAscList . labNodes $ g++labelsetFromGraph g = (S.map snd) . lnodesetFromGraph $ g++mkUqGraph vs es = (insEdges' . insUqNodes vs) empty+ where+ insEdges' g = foldl' (flip insEdge) g es++ +labelExists l g = let (mcontext,gr) = matchLabel l g+ in if (isJust mcontext)+ then True+ else False++{-+lookupLabel l g = let (mcontext,gr) = matchLabel l g+ in if (isJust mcontext)+ then (Ju+ else False +-} + +-- these fail because of duplicate nodes, which is the right thing.+t, t1 :: Gr String Float+t = mkUqGraph [(1,""), (0,"")] [] +t1 = insUqNode (1,"") . insUqNode (0, "") $ empty++++addLab :: (DynGraph g, Ord a) => a -> g a b -> g a b+addLab a g = run_ g $ insMapNodeM a+ +-- fails, as it should, because dupe+t2 :: Gr String ()+t2 = addLab "" . addLab "" $ empty+++modLab :: (Ord a, DynGraph g) => (a -> a) -> a -> g a b -> g a b+modLab f nl g = run_ g $ do+ oldgraph <- return . snd =<< get -- couldn't we just say: g instead of oldgraph and skip this?+ let ( mbOldContext, oldRemainingGr ) = matchLabel nl $ oldgraph+ mbNewGraph = do (fr, nodeId, nodeLabel, to) <- ( mbOldContext )+ return $ (fr, nodeId, f nodeLabel, to) & oldRemainingGr+ return $ maybe oldgraph id mbNewGraph
+ src/ViewPagination.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module ViewPagination where++import Data.List+import Misc+import Text.StringTemplate+data Pagination = Pagination { currentpage :: Int+ , resultsPerPage :: Int + , baselink :: String+ , paginationtitle :: String + }++paginationRanges :: Pagination -> [a] -> [[(a,Int)]]+paginationRanges pg datacells = splitList (resultsPerPage pg) $ zip datacells [1..]++paintPaginationBar :: STGroup String -> [[String]] -> Pagination -> String+paintPaginationBar templates datacells pg =+ let r = renderTemplateGroup templates+ paintlink (pageindex,range) = case range of+ [] -> ""+ (_,fr):xs -> let to = last . map snd $ xs+ attrs = [("currentpage",show pageindex),+ ("resultsPerPage",show $ resultsPerPage pg),+ ("from",show fr),+ ("to",show to)]+ in if (currentpage pg) == pageindex+ then r attrs "paginationlinkselected" + else r attrs "paginationlinkunselected" + pglinks = map paintlink $ zip [1..] (paginationRanges pg datacells )++ in (paginationtitle pg) ++ ( concat . intersperse " | " $ pglinks )++++getPaginatedCells datacells pg = fromTo fromRow toRow datacells+ where (fromRow,toRow) = currentPaginationFromTo datacells pg++currentPaginationFromTo :: [[a]] -> Pagination -> (Int,Int)+currentPaginationFromTo datacells pg =+ --let currentPaginationRange = paginationRanges pg datacells !! ( (currentpage pg) -1)+ case paginationRanges pg datacells of+ [] -> (0,0)+ prs -> let currrange = prs !! ((currentpage pg)-1)+ in case currrange of+ [] -> (0,0)+ ((firstval,firstindex):xs) -> (firstindex, (last . map snd ) xs)+++splitList :: Int -> [a] -> [[a]]+splitList _ [] = []+splitList n l@(x:xs) =+ let (a,b') = genericSplitAt n l + b = splitList n b'+ in a : b+
+ src/ViewStuff.hs view
@@ -0,0 +1,7 @@+module ViewStuff (+ module View,+ module ViewPagination+ ) where++import View+import ViewPagination