diff --git a/happs-tutorial.cabal b/happs-tutorial.cabal --- a/happs-tutorial.cabal +++ b/happs-tutorial.cabal @@ -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 diff --git a/src/ControllerGetActions.hs b/src/ControllerGetActions.hs new file mode 100644 --- /dev/null +++ b/src/ControllerGetActions.hs @@ -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" + + + + diff --git a/src/ControllerMisc.hs b/src/ControllerMisc.hs new file mode 100644 --- /dev/null +++ b/src/ControllerMisc.hs @@ -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 diff --git a/src/ControllerPostActions.hs b/src/ControllerPostActions.hs new file mode 100644 --- /dev/null +++ b/src/ControllerPostActions.hs @@ -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" diff --git a/src/Debugging.hs b/src/Debugging.hs new file mode 100644 --- /dev/null +++ b/src/Debugging.hs @@ -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 diff --git a/src/SerializeableSocialGraph.hs b/src/SerializeableSocialGraph.hs new file mode 100644 --- /dev/null +++ b/src/SerializeableSocialGraph.hs @@ -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) + diff --git a/src/StateStuff.hs b/src/StateStuff.hs new file mode 100644 --- /dev/null +++ b/src/StateStuff.hs @@ -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 + diff --git a/src/UniqueLabelsGraph.hs b/src/UniqueLabelsGraph.hs new file mode 100644 --- /dev/null +++ b/src/UniqueLabelsGraph.hs @@ -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 diff --git a/src/ViewPagination.hs b/src/ViewPagination.hs new file mode 100644 --- /dev/null +++ b/src/ViewPagination.hs @@ -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 + diff --git a/src/ViewStuff.hs b/src/ViewStuff.hs new file mode 100644 --- /dev/null +++ b/src/ViewStuff.hs @@ -0,0 +1,7 @@ +module ViewStuff ( + module View, + module ViewPagination + ) where + +import View +import ViewPagination