RESTng (empty) → 0.1
raw patch · 51 files changed
+4027/−0 lines, 51 filesdep +HDBCdep +HDBC-postgresqldep +basesetup-changedbinary-added
Dependencies added: HDBC, HDBC-postgresql, base, mtl, old-time, parsec, redHandlers, xhtml, yuiGrid
Files
- AUTHORS +3/−0
- Example/Common.hs +59/−0
- Example/Config.hs +14/−0
- Example/CreateSchema.hs +15/−0
- Example/FrontPage.hs +60/−0
- Example/InLineCSS.hs +30/−0
- Example/Main.hs +71/−0
- Example/Makefile +15/−0
- Example/README +71/−0
- Example/Resource.hs +67/−0
- Example/Resource/Author.hs +71/−0
- Example/Resource/Book.hs +87/−0
- Example/Resource/ExampleAppTag.hs +13/−0
- Example/Search.hs +89/−0
- Example/Tags.hs +65/−0
- Example/public/header.gif binary
- LICENSE +25/−0
- README +45/−0
- RESTng.cabal +55/−0
- RESTng/Database/Record.hs +109/−0
- RESTng/Database/SQL.hs +12/−0
- RESTng/Database/SQL/Print.hs +118/−0
- RESTng/Database/SQL/Sql.hs +176/−0
- RESTng/RESTngMonad.hs +82/−0
- RESTng/Resources.hs +15/−0
- RESTng/Resources/Comment.hs +113/−0
- RESTng/Resources/Rating.hs +163/−0
- RESTng/Resources/ResourceTag.hs +142/−0
- RESTng/Resources/User.hs +15/−0
- RESTng/Resources/UserCRUD.hs +33/−0
- RESTng/Resources/UserModel.hs +53/−0
- RESTng/RqHandlers.hs +11/−0
- RESTng/RqHandlers/GridHandler.hs +29/−0
- RESTng/RqHandlers/Response.hs +66/−0
- RESTng/System.hs +45/−0
- RESTng/System/Annotation.hs +91/−0
- RESTng/System/Association.hs +103/−0
- RESTng/System/Authentication.hs +132/−0
- RESTng/System/CRUD.hs +334/−0
- RESTng/System/Component.hs +108/−0
- RESTng/System/FormFields.hs +102/−0
- RESTng/System/ORM.hs +370/−0
- RESTng/System/ORMTypesConv.hs +108/−0
- RESTng/System/Permission.hs +65/−0
- RESTng/System/PersistableResource.hs +70/−0
- RESTng/System/Proxy.hs +14/−0
- RESTng/System/RelationalResource.hs +168/−0
- RESTng/System/Resource.hs +43/−0
- RESTng/System/WebResource.hs +246/−0
- RESTng/Utils.hs +30/−0
- Setup.lhs +6/−0
+ AUTHORS view
@@ -0,0 +1,3 @@+Tom Nielsen (tanielsen@gmail.com): Initital design and development.+Sergio Urinovsky (sergio.urinovsky@gmail.com): Design and lead developer.+
+ Example/Common.hs view
@@ -0,0 +1,59 @@+module Common where++import Prelude hiding (div,span)++import Data.List (intersperse)+import Control.Monad (liftM2)+import Database.HDBC (toSql)++import Text.CxML hiding (title)+import Text.YuiGrid+import Network.HTTP.RedHandler (RequestContext)++import RESTng.Resources (projectAndOrderByRatingQuery)+import RESTng.System++import Resource+import InLineCSS+++-------------------------------------------+------ Most highly rated books ---------+-------------------------------------------++ratedBooksView :: [(Book,Double)] -> CxML RequestContext+ratedBooksView = concatCxML . intersperse br . map showBookAndRating+ where+ showBookAndRating (art,rating) = div /- [+ span /- [ t "Book:"],+ span /- [ showShortURLHtml art ]+ ] ++++ div /- [+ span /- [ t "Rating:"],+ span /- [ t $ show rating ] + ]++-------------------------------+------ rated resources --------+-------------------------------++ratedResourcesData :: RelationalResource a => Proxy a -> SqlCommand -> RESTng [(a, Double)]+ratedResourcesData pr query = liftHDBC_0 $ runQueryN sqlRecordParser query++highlyRatedResourcesQuery :: RelationalResource a => Proxy a -> SqlCommand+highlyRatedResourcesQuery pr = projectAndOrderByRatingQuery pr $ sqlSelect [] [] pr+++------------------------------+-------- showing authors ----+------------------------------+authorsShow :: [Author] -> CxML RequestContext+authorsShow = concatCxML . intersperse br . map showShortURLHtml++-------------------------------------------+------ Helper functions -------------------+-------------------------------------------++withTitleBox :: String -> GridElement a -> GridElement a+withTitleBox tit b = toContainer [nearTop $ mediumText $ smallMarginBottomCSS $ toBox (t tit), b]+
+ Example/Config.hs view
@@ -0,0 +1,14 @@+module Config where++import RESTng.System (runRESTng)++-----------------------------+-- database configuration ---+-----------------------------+connString = "host=dbhost dbname=dbname user=username password=pwd"+runDB = runRESTng connString++----------------------+-- file structure ----+----------------------+publicFilesDir = "./public/"
+ Example/CreateSchema.hs view
@@ -0,0 +1,15 @@+module Main where++import RESTng.System+import RESTng.Resources (userProxy, commentProxy, ratingVoteProxy, resourceTagProxy)++import Config (connString)+import Resource++systemResourcesList = [CrBox userProxy, CrBox commentProxy, CrBox ratingVoteProxy, CrBox resourceTagProxy]++applicationResourcesList = [CrBox authorProxy, CrBox bookProxy]++main = ensureResourceTables (systemResourcesList ++ applicationResourcesList) typesAssoc connString++
+ Example/FrontPage.hs view
@@ -0,0 +1,60 @@+module FrontPage (+ frontPage+ ) where++import Prelude hiding (div,span)+import Data.List (intersperse)+import Control.Monad (liftM2)+import Text.ParserCombinators.Parsec (parse)+import Database.HDBC (SqlValue, toSql)++import Text.CxML hiding (title)+import Text.YuiGrid++import RESTng.RqHandlers+import RESTng.System+import RESTng.Resources --(tagLink)++import Resource+import InLineCSS+import Common+++frontPage :: RqHandlerT RESTng RESTngResp+frontPage = withDocName "index" $ + okBoxesM [+ return $ bigText $ smallMarginBottomCSS $ nearTop $ boxInMain $ t "This site is for ...",+ populatedTagsBox >>= return . nearRight . setColumnsVote 2 . commonLayoutHints,+ highlyRatedBooksBox >>= return . nearLeft . setColumnsVote 2 . commonLayoutHints+ ]+ where+ commonLayoutHints = smallMarginBottomCSS . giveBorderCSS . inMain++-------------------------------------------+---------- Most populated tags ------------+-------------------------------------------++populatedTagsBox :: RESTng (GridElement RequestContext)+populatedTagsBox = do tagsData <- populatedTagsData+ return $ withTitleBox "Most populated tags:" (toBox $ listTagsData tagsData)+ where+ listTagsData :: [(Integer, String)] -> CxML RequestContext+ listTagsData dat = div /- map buildLink dat+ buildLink (qty, tagname) = tagLink' tagname (Just qty) +++ br+++populatedTagsData :: RESTng [(Integer, String)]+populatedTagsData = liftHDBC_0 $ runQueryN sqlRecordParser populatedTagsQuery++populatedTagsQuery :: SqlCommand+populatedTagsQuery = setOrderDesc "1" $ projectAttrs ["tag"] $ countRows $ (sqlSelect [] [] exampleAppTagProxy) {groupBy = ["tag"]}+++-------------------------------------------+------ Most highly rated books ---------+-------------------------------------------+highlyRatedBooksBox :: RESTng (GridElement RequestContext)+highlyRatedBooksBox = do booksAndRatings <- ratedResourcesData bookProxy $ highlyRatedResourcesQuery bookProxy+ return $ withTitleBox "Most highly rated books:" $ toBox (ratedBooksView booksAndRatings)++
+ Example/InLineCSS.hs view
@@ -0,0 +1,30 @@+module InLineCSS where++import Text.CxML (CssInlineDecl)+import Text.YuiGrid++bigText :: HasLayoutHints a => a -> a+bigText = addCss bigTextRls++bigTextRls :: CssInlineDecl+bigTextRls = ("bigText", [+ ("clear","left"),+ ("font-size","2em"),+ ("font-weight","bolder"),+ ("margin","0pt 0pt 0pt 40px"),+ ("padding-left","16px"),+ ("top","5px")+ ] )++mediumText :: HasLayoutHints a => a -> a+mediumText = addCss mediumTextRls++mediumTextRls :: CssInlineDecl+mediumTextRls = ("mediumText", [+ ("clear","left"),+ ("font-size","1.5em"),+ ("font-weight","bolder"),+ ("margin","0pt 0pt 0pt 20px"),+ ("padding-left","8px"),+ ("top","5px")+ ] )
+ Example/Main.hs view
@@ -0,0 +1,71 @@+module Main where++import Control.Monad.Trans (lift)+-- useful for building the parent-children structure for the hierarchical CRUD+import RESTng.Resources (commentProxy, ratingVoteProxy, userProxy)++-- useful for building the application grid context+import qualified Text.CxML as Cx (t, h1logo, vertNav, CxML)+import Text.YuiGrid++import RESTng.RqHandlers+import RESTng.System++import Config+import Resource+import FrontPage (frontPage)+import Tags (tagsHandler)+import Search (searchForm, searchHandler)+++-----------------------------------------------+-- CRUD hierarchy+-----------------------------------------------+resList = [+ CB authorProxy [CCB bookProxy, CCB exampleAppTagProxy],+ CB bookProxy [CCB commentProxy, CCB ratingVoteProxy, CCB exampleAppTagProxy],++ CB userProxy [],+ CB commentProxy [],+ CB ratingVoteProxy [],+ CB exampleAppTagProxy []+ ]++-----------------------------------------------+-- Application GRID context+-----------------------------------------------+appCtx :: RqHandlerT RESTng RESTngResp -> RqHandlerT RESTng RESTngResp+appCtx h = afterSettingAuthUser $ do+ usrName <- lift authdUsername+ inGridWithElems [+ boxInFooter (Cx.t "Footer goes here."),+ boxInHeader (Cx.h1logo "Header image goes in the URL" "/images/header.gif"),+ smallMarginBottomCSS $ nearLeft $ setColumnsVote 2 $ nearBottom $ boxInHeader (loginControl usrName),+ smallMarginBottomCSS $ nearRight $ setColumnsVote 2 $ nearBottom $ boxInHeader searchForm,+ boxInLeftSidebar ( Cx.vertNav [("Home", "/"),+ ("About", "/about"),+ ("Contact", "/contact")])+ ] $ withTitle "Hello World" h+++loginControl ::String -> Cx.CxML RequestContext+loginControl userName = Cx.t ("User: " ++ userName)++-----------------------------------------------+-- Routes and handlers+-----------------------------------------------+mainHandlers :: [IORqHandler BasicRsp]+mainHandlers = [modResp restngRespToRsp applicationPages, imgFilesHandler]++imgFilesHandler = under "images" $ mapDir publicFilesDir++applicationPages :: IORqHandler RESTngResp+applicationPages = db $ appCtx $ anyOf [anyLoginHandler, resourcesHandler resList, tagsHandler, searchHandler, frontPage]+ where+ db = safeDbRqHandler connString okNonCxMLStrRsp++-----------------------------------------------+-- Main daemon and port+-----------------------------------------------+main :: IO ()+main = runHttpServer 8080 mainHandlers
+ Example/Makefile view
@@ -0,0 +1,15 @@+.PHONY: all application scripts clean++all: application scripts++application:+ ghc -o main --make Main.hs++scripts:+ ghc --make CreateSchema.hs++clean:+ -rm main CreateSchema+ -rm *.o *.hi *~+ -rm Resource/*.o Resource/*.hi Resource/*~+
+ Example/README view
@@ -0,0 +1,71 @@+Note: +-----+RESTng does not support different rdbms yet. For the moment we are just using PostgreSQL.+++The Example Application:+------------------------++The example application is a standalone RESTful web application running in the port 8080.++In this application the resources and resource relations are: + - User defined resources: authors and books+ - System defined resources: tags, rating votes and comments.+ - Resource relations: + - Authors can be tagged and have books. + - Books can also be tagged, can be voted and have comments.++ (This is defined in the function resList in the file main.hs)++ These kind of urls and actions will be available:++ GET http://localhost:8080/author/ (list the authors)+ GET http://localhost:8080/author/new.html (show the form for filling an author)+ POST http://localhost:8080/author/new.html (create the author)+ GET http://localhost:8080/author/1.html (show the author with id 1)+ GET http://localhost:8080/author/1/edit.html (show the form for editing the author with id 1)+ POST http://localhost:8080/author/1/edit.html (update the author with id 1)+ POST http://localhost:8080/author/1/delete.html (delete the author with id 1)++ GET http://localhost:8080/book/ (list the books)+ GET http://localhost:8080/book/new.html (show the form for filling an book)+ and so on for the other actions (like authors)++ Also there are actions for comments and other system resources.++ And there are actions available for nested resources using hierarchical URLs, i.e.++ GET http://localhost:8080/author/1/book/ (list the books of author with id 1)+ GET http://localhost:8080/author/1/book/new (likewise author new. The form won't have a visible field for the author since it is already defined.)+ POST http://localhost:8080/author/1/book/new (The form does not have the author field since goes in the URL)+ and so on for the other actions on books++ Also:+ GET http://localhost:8080/book/1/comment/new.html+ POST http://localhost:8080/book/1/comment/new.html++ GET http://localhost:8080/author/1/resourcetag/new.html++ just to name a few.+++DB configuration:+-----------------+1) Create a new database (without tables) and setup access permissions as you like.+2) Modify the file Config.hs to setup your connection string to the db.+++Build: +------++Simply run "make". 2 executables will be created. +They are:+ - CreateSchema: Run this one first for creating the tables.+ - main: This is the web standalone application.++Run:+----+1) Run "main" for running the application.+2) Start a browser and try actions like the ones mentioned above in the section "The Example Application".++
+ Example/Resource.hs view
@@ -0,0 +1,67 @@+module Resource (+ module Resource.Author,+ module Resource.Book,+ module Resource.ExampleAppTag,+ ) where++import Text.YuiGrid++import RESTng.System+import RESTng.Resources (comments, ratings, resourceTags)++import Resource.Author (Author, authorProxy)+import Resource.Book (Book, bookProxy)+import Resource.ExampleAppTag(ExampleAppTag, exampleAppTagProxy)++------------------------+-- Resource Annotations+------------------------+instance AnnotatedResource Author+ where annotations = [+ nearRight $ setColumnsVote 2 $ childComponent bookProxy,+ nearBottom $ setColumnsVote 2 $ giveBorderCSS $ + (dummyStringAnnotation "Tags") `absorveAnn` resourceTags+ ]++instance AnnotatedResource Book+ where annotations = (parentComponent authorProxy) : + map (smallMarginBottomCSS)+ [+ nearTop $ dummyStringAnnotation "This is a dummy annotation on the top of the book to illustrate a box here",+ nearRight $ setColumnsVote 3 $ dummyStringAnnotation "Other dummy annotation box here to show 3 columns",+ setColumnsVote 3 $ comments,+ nearBottom $ setColumnsVote 2 $ nearRight $ giveBorderCSS $ ratings,+ nearBottom $ setColumnsVote 2 $ giveBorderCSS $ + (dummyStringAnnotation "Tags") `absorveAnn` resourceTags+ ]++instance AnnotatedResource ExampleAppTag+ where annotations = [parentListComponent [ParentBox authorProxy, ParentBox bookProxy] ]++------------------------+-- Resource CRUDs+------------------------++instance CRUDable Author+ where+ canGetCreationForm = everybodyCan+ canCreate = everybodyCan+ canRetrieve = everybodyCan+ canUpdate = everybodyCan+ canDelete = everybodyCan++instance CRUDable Book+ where+ canGetCreationForm = everybodyCan+ canCreate = everybodyCan+ canRetrieve = everybodyCan+ canUpdate = everybodyCan+ canDelete = everybodyCan++instance CRUDable ExampleAppTag+ where+ canGetCreationForm = everybodyCan+ canCreate = everybodyCan+ canRetrieve = everybodyCan+ canUpdate = everybodyCan+ canDelete = everybodyCan
+ Example/Resource/Author.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fallow-incoherent-instances #-}++module Resource.Author where++import Prelude hiding (div,span)+import Database.HDBC (toSql)+import Text.ParserCombinators.Parsec (parse)++import Text.CxML+import Text.YuiGrid++import RESTng.System++data Author = Author {+ author_id :: Integer,+ name :: String,+ age :: Integer+ }++authorProxy :: Proxy Author+authorProxy = undefined+++instance Resource Author where+ resourceType _ = "Author"+ key = author_id+ setKey res k = res {author_id = k}++ userFields _ = ["name", "age"]+++instance RelationalResource Author where++ userFieldsToSql res = [toSql $ name res, toSql $ age res]++ sqlUserFieldsParser (k, _) =+ do+ (name, age) <- sqlRecordParser+ return (Author k name age)++instance CanCreateSchemaForResource Author where+ --userFieldsReps :: Proxy a -> [TypeRep]+ userFieldsReps _ = [stringTR, integerTR]+ --userFieldsDefaultValues :: Proxy a -> [Maybe String] -- default value sql expression+ userFieldsDefaultValues _ = [Nothing, Nothing]++instance PersistableResource Author where+ persistableFunctions = persistableFromRelational++instance WebResource Author where+ userFieldValues res = [showField $ name res, showField $ age res]++ userFieldValuesParser (k, _) = + do+ name <- parseNotEmpty "name"+ age <- parseField "age"+ return (Author k name age)++{-+ showHtml (Author k name age) =+ h3 /- [t name] + +++ h4 /- [t $ "Age: " ++ show age]+-}+ showShortHtml = t . name+++instance InGridResource Author where+ showLayout a b c = map (addCss ("padded", [("padding","3px")])) (showLayoutDefault a b c)+ listView = listInBoxesView+
+ Example/Resource/Book.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}++module Resource.Book where++import Database.HDBC (toSql)+import Text.ParserCombinators.Parsec (parse)+import Data.Generics++import Text.CxML hiding (title)++import RESTng.System++import Resource.Author(Author)++data Book = Book {+ book_id :: Integer,+ title :: String,+ pages :: Integer,+ author_id :: Integer+ } deriving (Data, Typeable)+++bookProxy :: Proxy Book+bookProxy = undefined+++instance Resource Book where+ resourceType _ = "Book"+ key = book_id+ setKey res k = res {book_id = k}++ userFields _ = ["title", "pages", "author_id"]+++instance RelationalResource Book where+ userFieldsToSql res = [toSql $ title res, toSql $ pages res, toSql $ author_id res]++-- sqlUserFieldsParser :: SystemFields -> SqlValueParser a+ sqlUserFieldsParser (k, _) = + do+ (title, pages, aid) <- sqlRecordParser+ return (Book k title pages aid)+++instance PersistableResource Book where+ persistableFunctions = persistableFromRelational++instance WebResource Book where+ userFieldValues res = [showField $ title res, showField $ pages res, showField $ author_id res]++ userFieldValuesParser (k, _) = + do+ ti <- parseNotEmpty "title"+ pa <- parseField "pages"+ aid <- parseField "author_id"+ return (Book k ti pa aid)++ showShortHtml (Book k title pages aid) = t title+ showHtml b@(Book k title pages aid) = (showShortURLHtml b)^^.mediumTextRls+ +++ p /- [t $ "(" ++ show pages ++ " pages)"]+++instance InGridResource Book where+ listView = listInBoxesView++-------------------------+-- belongsTo Author+-------------------------+instance RelationalOneToMany Author Book where -- requires FlexibleInstances & MultiParamTypeClasses+ --fkValue :: Proxy a -> Comment -> Integer+ fkValue _ = author_id+ fkName _ _ = "author_id"++instance AssocOneToMany Author Book where -- requires FlexibleInstances & MultiParamTypeClasses+ oneToManyFunctions = oneToManyFromRelational+++mediumTextRls :: CssInlineDecl+mediumTextRls = ("mediumText", [+ --("clear","left"),+ ("font-size","1.5em"),+ ("font-weight","bolder"),+ --("margin","0pt 0pt 0pt 20px"),+ --("padding-left","8px"),+ ("top","5px")+ ] )+
+ Example/Resource/ExampleAppTag.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}++module Resource.ExampleAppTag where++import RESTng.System+import RESTng.Resources (resourceTags, ResourceTag)++newtype ExampleAppTag = FTag ResourceTag + deriving (Resource, RelationalResource, PersistableResource, WebResource, InGridResource, RelationalOneToMany a, AssocOneToMany a)++exampleAppTagProxy :: Proxy ExampleAppTag+exampleAppTagProxy = undefined+
+ Example/Search.hs view
@@ -0,0 +1,89 @@+module Search where++import Prelude hiding (div,span)+import Data.List (intersperse)+import Control.Monad (liftM, liftM2)+import Text.ParserCombinators.Parsec (parse)+import Database.HDBC (SqlValue, toSql)++import Text.CxML hiding (title)+import Text.YuiGrid++import RESTng.RqHandlers+import RESTng.System++import Resource+import InLineCSS+import Common (authorsShow, withTitleBox)+import Tags (booksShow)+++searchForm :: CxML RequestContext+searchForm+ = form!("method","post")!("action","/search.html")+ /- [+ textfield "search", + button!("name","action")!("value","submit") /- [t "Search"]+ ]++searchHandler :: RqHandlerT RESTng RESTngResp+searchHandler = --withDocName "search" $ withQueryField "search" $ \q ->+ withDocName "search" $ withPostField "search" $ \q ->+ okBoxesM [+ return $ bigText $ smallMarginBottomCSS $ nearTop $ boxInMain $ t ("Found it in: "),++ liftM (nearLeft . setColumnsVote 2 . commonLayoutHints) $ tagsMatchingBox q,+ liftM (nearRight . setColumnsVote 2 . commonLayoutHints) $ booksMatchingBox q,+ liftM (nearBottom . commonLayoutHints) $ authorsMatchingBox q+ ]+ where+ commonLayoutHints = smallMarginBottomCSS . giveBorderCSS . inMain++-------------------------------+---------- Tags matching -----+-------------------------------+tagsMatchingBox :: String -> RESTng (GridElement RequestContext)+tagsMatchingBox s = do tagListCxML <- listingResource exampleAppTagProxy [("tag",s)] []+ return $ withTitleBox "Tags matching:" tagListCxML+++-------------------------------+------ Books matching -----+-------------------------------+booksMatchingBox :: String -> RESTng (GridElement RequestContext)+booksMatchingBox s = + do books <- booksMatchingData s+ return $ withTitleBox "Books matching:" $ toBox (booksShow books)+++booksMatchingData :: String -> RESTng [Book]+booksMatchingData s = liftHDBC_0 $ runQueryN sqlRecordParser (booksMatchingQuery s)++booksMatchingQuery :: String -> SqlCommand+booksMatchingQuery s = addCriterium (inBookExpr `or_` inAuthorExpr) $+ sqlSelect [] [] bookProxy+ where+ inBookExpr = caseInsensitiveSearchExpr ["title"] s+ inAuthorExpr = (tableName authorProxy ++ "_id") `in_` + (projectJustAttrs ["DISTINCT id"] $ authorsMatchingQuery s)++-------------------------------+------ Authors matching -----+-------------------------------+authorsMatchingBox :: String -> RESTng (GridElement RequestContext)+authorsMatchingBox s = do authors <- authorsMatchingData s+ return $ withTitleBox "Authors:" $ toBox (authorsShow authors)++authorsMatchingData :: String -> RESTng [Author]+authorsMatchingData s = liftHDBC_0 $ runQueryN sqlRecordParser (authorsMatchingQuery s)+-- FIXME: in order to be more DRY, do some runQueryN' such that+-- authorsMatchingData s = runQueryN' (authorsMatchingQuery s)+-- so the function has type+-- runQueryN' :: SqlRecord a => SqlCommand -> RESTng [a]+++authorsMatchingQuery :: String -> SqlCommand+authorsMatchingQuery s = addCriterium (caseInsensitiveSearchExpr ["name"] s) $+ sqlSelect [] [] authorProxy++--FIXME: can search authors related to authorships containing s here also.
+ Example/Tags.hs view
@@ -0,0 +1,65 @@+module Tags where++import Prelude hiding (div,span)+import Data.List (intersperse)+import Control.Monad (liftM2)+import Text.ParserCombinators.Parsec (parse)+import Database.HDBC (SqlValue, toSql)++import Text.CxML hiding (title)+import Text.YuiGrid++import RESTng.RqHandlers+import RESTng.System+import RESTng.Resources (restrictByTagQuery)++import Resource+import InLineCSS+import Common+++tagsHandler :: RqHandlerT RESTng RESTngResp+tagsHandler = under "Tag" $ withDocNameString $ \tagname -> + okBoxesM [+ return $ bigText $ smallMarginBottomCSS $ nearTop $ boxInMain $ t ("Resources tagged with " ++ tagname),+ highlyRatedBooksWithTagBox tagname >>= return . nearLeft . setColumnsVote 2 . commonLayoutHints,+ recentBooksWithTagBox tagname >>= return . nearRight . setColumnsVote 2 . commonLayoutHints+ ]+ where+ commonLayoutHints = smallMarginBottomCSS . giveBorderCSS . inMain+++--------------------------------------------------------+--- Most highly rated books with specific tag -------+--------------------------------------------------------+highlyRatedBooksWithTagBox :: String -> RESTng (GridElement RequestContext)+highlyRatedBooksWithTagBox tagname = + do booksAndRatings <- ratedResourcesData bookProxy (highlyRatedResourcesWithTagQuery bookProxy tagname)+ return $ withTitleBox "Most highly rated books:" $ toBox (ratedBooksView booksAndRatings)+++highlyRatedResourcesWithTagQuery :: RelationalResource a => Proxy a -> String -> SqlCommand+highlyRatedResourcesWithTagQuery pr tagname = restrictByTagQuery pr tagname (highlyRatedResourcesQuery pr)+++-------------------------------------------+--- Most recent books with this tag ----+-------------------------------------------+recentBooksWithTagBox :: String -> RESTng (GridElement RequestContext)+recentBooksWithTagBox tagname = + do books <- recentBooksWithTagData tagname+ return $ withTitleBox "Recent books:" $ toBox (booksShow books)+++recentBooksWithTagData :: String -> RESTng [Book]+recentBooksWithTagData tagname = liftHDBC_0 $ runQueryN sqlRecordParser (recentBooksWithTagQuery tagname)++recentBooksWithTagQuery :: String -> SqlCommand+recentBooksWithTagQuery tagname = setOrderDesc (tableName bookProxy ++ ".id") $+ restrictByTagQuery bookProxy tagname $ + sqlSelect [] [] bookProxy+++booksShow :: [Book] -> CxML RequestContext+booksShow = concatCxML . intersperse (br +++ br ) . map showShortURLHtml+
+ Example/public/header.gif view
binary file changed (absent → 26128 bytes)
+ LICENSE view
@@ -0,0 +1,25 @@+The MIT License++Copyright (c) 2009 RedNucleus LTD++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.+
+ README view
@@ -0,0 +1,45 @@+RESTng: A framework for writing RESTful applications++It is experimental, incomplete and we are currently not actively developing it.+Anyway, there are several interesting features so we have decided to release them to share the ideas.+++Features include:+++Yahoo Grids:+The presentation uses the yuiGrid (grids defined by layout hints rendered with the yahoo grids).+++Annotations: +A resource can be annotated so that related information can be shown. The presentation of a resource to html is done by multiple annotations, each one possibly in different boxes with different layout hints.+++Associations: +Resource collections "has many" associations can be defined allowing:++ - Lookup functions in the Model for associated resources+ - Some annotations are available to be used like childComponent or parentComponent to list children resources or show the parent in separate boxes.+ - Hierarchical URLs are automatically handled in the control part. i.e.: + GET http://site/book/3/chapter/1 (get the chapter 1 of book with id 3)+ GET http://site/book/3/chapter/new (get a form for filling data for the new chapter for book with id 3)+ POST http://site/book/3/chapter/new (create a new chapter for the book with id 3)+ and so on for updates, list and delete actions++ - Polymorphic associations are supported (i.e.: comment associated to books and also associated to authors).++ORM:+The ORM generates tables in the DB from the Haskell record type. Existing tables and attributes are kept and missing attributes are added.++Other features supported: + - Tags+ - Ratings+ - Comments+ - Users and login+ - CMS-like form fields validations.+++Please send comments or questions to:+ - Tomas Nielsen <tanielsen@gmail.com>+ - Sergio Urinovsky <sergio.urinovsky@gmail.com>+
+ RESTng.cabal view
@@ -0,0 +1,55 @@+Name: RESTng+Version: 0.1+Synopsis: A framework for writing RESTful applications.+Description: RESTng is still experimental and incomplete, but many implemented features may be of interest, including: grids for presentation, + hierarchical URLs automatic handling, ORM generates tables from haskell records.+Category: Web+License: OtherLicense+License-file: LICENSE+Author: RedNucleus (see AUTHORS)+Maintainer: none+Stability: Experimental+Build-Type: Simple+Build-Depends: base <4, parsec, HDBC <2.0.0, HDBC-postgresql <2.0.0, redHandlers, mtl, old-time, yuiGrid==0.1, xhtml+Exposed-modules: RESTng.System,+ RESTng.Resources,+ RESTng.RqHandlers+Other-modules: RESTng.Utils,+ RESTng.Database.Record,+ RESTng.Database.SQL,+ RESTng.Resources.User,+ RESTng.Database.SQL.Print,+ RESTng.Database.SQL.Sql,+ RESTng.RESTngMonad,+ RESTng.System.Proxy,+ RESTng.System.Resource,+ RESTng.System.RelationalResource,+ RESTng.System.ORMTypesConv,+ RESTng.System.ORM,+ RESTng.System.PersistableResource,+ RESTng.System.WebResource,+ RESTng.System.CRUD,+ RESTng.System.FormFields,+ RESTng.System.Annotation,+ RESTng.System.Permission,+ RESTng.System.Association,+ RESTng.System.Component,+ RESTng.System.Authentication,+ RESTng.RqHandlers.GridHandler,+ RESTng.RqHandlers.Response,+ RESTng.Resources.User,+ RESTng.Resources.UserModel,+ RESTng.Resources.UserCRUD,+ RESTng.Resources.Comment,+ RESTng.Resources.Rating,+ RESTng.Resources.ResourceTag++Extra-source-files: AUTHORS, README,+ Example/README, Example/Makefile,+ Example/CreateSchema.hs, Example/Main.hs,+ Example/Common.hs, Example/InLineCSS.hs, Example/Search.hs,+ Example/Config.hs, Example/Tags.hs,+ Example/FrontPage.hs, Example/Resource.hs, + Example/Resource/Author.hs, Example/Resource/Book.hs, + Example/Resource/ExampleAppTag.hs,+ Example/public/header.gif
+ RESTng/Database/Record.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}++module RESTng.Database.Record where++import Control.Monad (liftM2, liftM3, liftM4, liftM5, ap)+import Database.HDBC.PostgreSQL (Connection)+import Database.HDBC (SqlType, SqlValue, fromSql, quickQuery', run, commit)+import Text.ParserCombinators.Parsec (GenParser, anyToken, parse)+import Data.Maybe (isJust, fromJust, fromMaybe)++import RESTng.Utils(safeHead)+import RESTng.Database.SQL++type SqlValueParser a = GenParser SqlValue () a++sqlFieldParser :: SqlType a => SqlValueParser a+sqlFieldParser = do tok <- anyToken;+ return $ fromSql tok++class SqlRecord a where+ sqlRecordParser :: SqlValueParser a++--instance SqlType a => SqlRecord a where+-- sqlRecordParser = sqlFieldParser++-- instance for fields. We cannot use the commented lines above since it is duplicated with +-- "instance RelationalResource a => SqlRecord a" declaration in RESTng++instance SqlRecord Bool where sqlRecordParser = sqlFieldParser+instance SqlRecord Int where sqlRecordParser = sqlFieldParser+instance SqlRecord Integer where sqlRecordParser = sqlFieldParser+instance SqlRecord Double where sqlRecordParser = sqlFieldParser+instance SqlRecord [Char] where sqlRecordParser = sqlFieldParser+++instance (SqlRecord a, SqlRecord b) => SqlRecord (a,b) where+ sqlRecordParser = liftM2 (,) sqlRecordParser sqlRecordParser++instance (SqlRecord a, SqlRecord b, SqlRecord c) => SqlRecord (a,b,c) where+ sqlRecordParser = liftM3 (,,) sqlRecordParser sqlRecordParser sqlRecordParser++instance (SqlRecord a, SqlRecord b, SqlRecord c, SqlRecord d) => SqlRecord (a,b,c,d) where+ sqlRecordParser = liftM4 (,,,) sqlRecordParser sqlRecordParser sqlRecordParser sqlRecordParser++instance (SqlRecord a, SqlRecord b, SqlRecord c, SqlRecord d, SqlRecord e) => SqlRecord (a,b,c,d,e) where+ sqlRecordParser = liftM5 (,,,,) sqlRecordParser sqlRecordParser sqlRecordParser sqlRecordParser sqlRecordParser++instance (SqlRecord a, SqlRecord b, SqlRecord c, SqlRecord d, SqlRecord e, SqlRecord f) => SqlRecord (a,b,c,d,e,f) where+ sqlRecordParser = return (,,,,,) `ap` sqlRecordParser `ap` sqlRecordParser `ap` sqlRecordParser + `ap` sqlRecordParser `ap` sqlRecordParser `ap` sqlRecordParser+++-- | Mapping from field type names to SQL type names. Usefull for creating tables+-- Should the default be a "text", or "" (what we will do with field types we don't know about ) +-- sqlType :: a -> String+-- sqlType _ = "text"+++runTransaction :: SqlCommand -> Connection -> IO Integer+runTransaction cmd conn+ = + do+ putStrLn $ show (sqlStr, sqlArgs)+ --FIXME: last line is for debugging. remove it for deployment+ rowsAffectedQty <- run conn sqlStr sqlArgs+ commit conn+ return rowsAffectedQty+ where+ (sqlStr, sqlArgs) = ppSqlCommand cmd++runTransactionReturningIds :: SqlCommand -> Connection -> IO [Integer]+runTransactionReturningIds cmd conn+ = + do+ putStrLn $ show (sqlStr, sqlArgs)+ --FIXME: last line is for debugging. remove it for deployment+ idRows <- quickQuery' conn sqlStr sqlArgs+ commit conn+ return (map fromSql $ concat idRows)+ where+ (sqlStr, sqlArgs) = ppSqlCommand cmd++runTransactionReturningId :: SqlCommand -> Connection -> IO (Maybe Integer)+runTransactionReturningId cmd conn = runTransactionReturningIds cmd conn >>= return . safeHead+++runQueryN :: SqlValueParser a -> SqlCommand -> Connection -> IO [a]+runQueryN parser cmd conn =+ do+ putStrLn $ show (sqlStr, sqlArgs)+ --FIXME: last line is for debugging. remove it for deployment+ rows <- quickQuery' conn sqlStr sqlArgs+ --return [ row | (Just row) <- map parseRow rows]+ -- what happens if the pattern matching fails? is it filtered or it is an exception?+ return [ fromJust maybeRow | maybeRow <- map parser' rows, isJust maybeRow]+ where+ (sqlStr, sqlArgs) = ppSqlCommand cmd+ parser' sqlvalues = case (parse parser "" sqlvalues) of+ Left err -> Nothing+ Right rec -> Just rec+++runQuery01 :: SqlValueParser a -> SqlCommand -> Connection -> IO (Maybe a)+runQuery01 parser cmd conn = runQueryN parser cmd conn >>= (return . safeHead)++runQuery1 :: SqlValueParser a -> SqlCommand -> Connection -> IO a+runQuery1 parser cmd conn = runQueryN parser cmd conn >>= (return . head)+
+ RESTng/Database/SQL.hs view
@@ -0,0 +1,12 @@+module RESTng.Database.SQL+ (+ module RESTng.Database.SQL.Sql,+ ppSqlCommand+ ) where++import RESTng.Database.SQL.Sql+import RESTng.Database.SQL.Print (ppSqlCommand)++-- for debugging+instance Show SqlCommand+ where show cmd = fst $ ppSqlCommand cmd
+ RESTng/Database/SQL/Print.hs view
@@ -0,0 +1,118 @@+module RESTng.Database.SQL.Print (ppSqlCommand) where++import Data.List(intersperse)+import Database.HDBC (SqlValue)++import RESTng.Database.SQL.Sql++ppSqlCommand :: SqlCommand -> (String, [SqlValue])++ppSqlCommand (SqlSelect cols ts crit grp ord lim off) = (strSql, values)+ where+ strSql = "SELECT " ++ strCols cols ++ strFrom ++ strWhere ++ strGrp grp ++ strOrd ord ++ strLimit lim ++ strOffset off+ strCols [] = "*"+ strCols cls = concat $ intersperse ", " cls+ strFrom = " FROM " ++ (concat $ intersperse ", " ts)+ (strWhere, values) = ppCriteria crit+ strGrp [] = ""+ strGrp cls = " GROUP BY " ++ (concat $ intersperse ", " cls)+ strOrd [] = ""+ strOrd ord = " ORDER BY " ++ (concat . intersperse ", ") (map ppOrd ord)+ strLimit Nothing = ""+ strLimit (Just i) = " LIMIT " ++ show i+ strOffset Nothing = ""+ strOffset (Just i) = " OFFSET " ++ show i+++ppSqlCommand (SqlInsertValues t colsAndExprs ret) = (strSql, values)+ where+ strSql = "INSERT INTO " ++ t ++ " (" ++ strCols ++ ")" +++ " VALUES (" ++ strExprs ++ ")" ++ strRet ret+ (cols,exprs) = unzip colsAndExprs+ strCols = concat $ intersperse ", " $ cols+ (strExprs', values) = ppExprs exprs+ strExprs = concat $ intersperse ", " $ strExprs'+ strRet Nothing = ""+ strRet (Just s) = " RETURNING " ++ s+++ppSqlCommand (SqlUpdateValues t colsAndExprs crit) = (strSql, values1 ++ values2)+ where+ strSql = "UPDATE " ++ t ++ " SET " ++ strAsignments ++ strWhere+ strAsignments = concat $ intersperse ", " $ (zipWith (\s1 s2 -> s1 ++ "=" ++ s2) cols strExprs)+ (cols,exprs) = unzip colsAndExprs+ (strExprs, values1) = ppExprs exprs+ (strWhere, values2) = ppCriteria crit++ppSqlCommand (SqlDelete t crit) = (strSql, values)+ where+ strSql = "DELETE FROM " ++ t ++ strWhere+ (strWhere, values) = ppCriteria crit++ppCriteria :: SqlExp -> (String, [SqlValue])+ppCriteria True_ = ("",[])+ppCriteria crit = (" WHERE " ++ str, vals)+ where+ (str,vals) = ppExpr crit+++ppExprs :: [SqlExp] -> ([String], [SqlValue]) --values list for each expression have been concatenated+ppExprs exprs = (strs, concat valss)+ where+ (strs,valss) = unzip $ map ppExpr exprs+++ppExpr :: SqlExp -> (String, [SqlValue])++ppExpr (False_) = ("FALSE", [])+ppExpr (True_) = ("TRUE", [])+ppExpr (Lower_ e) = let (s,vs) = ppExpr e in ("LOWER (" ++ s ++ ") ", vs)++ppExpr (AppBinOp And_ True_ e2) = ppExpr e2+ppExpr (AppBinOp And_ e1 e2)+ = let (s1,vs1) = ppExpr e1+ (s2,vs2) = ppExpr e2+ in+ (s1 ++ " AND " ++ s2, vs1 ++ vs2)++ppExpr (AppBinOp Or_ e1 e2)+ = let (s1,vs1) = ppExpr e1+ (s2,vs2) = ppExpr e2+ in+ ("(" ++ s1 ++ " OR " ++ s2 ++ ")", vs1 ++ vs2)+++ppExpr (AppBinOp IsEqualTo e1 e2)+ = let (s1,vs1) = ppExpr e1+ (s2,vs2) = ppExpr e2+ in+ (s1 ++ "=" ++ s2, vs1 ++ vs2)++ppExpr (AppBinOp In_ e1 e2)+ = let (s1,vs1) = ppExpr e1+ (s2,vs2) = ppExpr e2+ in+ (s1 ++ " IN (" ++ s2 ++ ")", vs1 ++ vs2)++ppExpr (AppBinOp Like_ e1 e2)+ = let (s1,vs1) = ppExpr e1+ (s2,vs2) = ppExpr e2+ in+ (s1 ++ " LIKE " ++ s2, vs1 ++ vs2)+++ppExpr (AnyCondition []) = (" FALSE ", [])+ppExpr (AnyCondition exprs) = (" (" ++ concat (intersperse " OR " strs) ++ ") ", concat vss)+ where+ (strs,vss) = unzip $ map ppExpr exprs++++ppExpr (Const s) = (s,[])+ppExpr (Value val) = ("?",[val])+ppExpr (Query cmd) = ppSqlCommand cmd++ppOrd :: (String,OrderDirection) -> String+ppOrd (col, OrderAsc) = col+ppOrd (col, OrderDesc) = col ++ " DESC"+
+ RESTng/Database/SQL/Sql.hs view
@@ -0,0 +1,176 @@+module RESTng.Database.SQL.Sql where++import RESTng.Utils (low)+import Database.HDBC (SqlValue, toSql)++data SqlCommand =+ SqlSelect { attrs :: [String],+ tables :: [String],+ criteria :: SqlExp,+ groupBy :: [String],+ order :: [(String,OrderDirection)],+ limit :: Maybe Integer,+ offset :: Maybe Integer+ }++ | SqlInsertValues+ { table :: String,+ set :: [(String,SqlExp)],+ returning :: Maybe String+ }++ | SqlUpdateValues+ { table :: String,+ set :: [(String,SqlExp)],+ criteria :: SqlExp+ }++ | SqlDelete+ { table :: String,+ criteria :: SqlExp+ }++++data OrderDirection = OrderAsc | OrderDesc++--data SqlExpr = AppBinOp BinOp SqlExp SqlExp | Const String| Value SQLValue+--data BinOp = BinOp Fixity String+--data Fixity = Prefix | Infix++data SqlExp = False_ | True_ -- nullary ops here+ | Lower_ SqlExp -- monary ops her+ | AppBinOp BinOp SqlExp SqlExp + | Const String | Value SqlValue | Query SqlCommand | AnyCondition [SqlExp]++data BinOp = IsEqualTo | In_ | Like_ | Or_ | And_++(.==.) :: SqlExp -> SqlExp -> SqlExp+(.==.) = AppBinOp IsEqualTo+like_ :: SqlExp -> SqlExp -> SqlExp+like_ = AppBinOp Like_+or_ = AppBinOp Or_++--(.=.) = AppBinOp (BinOp Infix "=")+--restrictAttrOp :: BinOp String -> SQLValue -> SqlCommand -> SqlCommand++in_ :: String -> SqlCommand -> SqlExp+name `in_` query = AppBinOp In_ (Const name) (Query query)++lowerLike :: String -> SqlValue -> SqlExp+col `lowerLike` s = Lower_ (Const col) `like_` Value s+++---------------------------------------------------+-- combinators for creating or modifying commands+---------------------------------------------------++-- basic creation of commands+selectCmd :: [String] -> SqlCommand+selectCmd tbls = SqlSelect [] tbls True_ [] [] Nothing Nothing++insertCmd :: String -> [(String,SqlValue)] -> SqlCommand+insertCmd tbl vals = setValues vals (SqlInsertValues tbl [] Nothing)++updateCmd :: String -> [(String,SqlValue)] -> SqlCommand+updateCmd tbl vals = setValues vals (SqlUpdateValues tbl [] True_)++deleteCmd :: String -> SqlCommand+deleteCmd tbl = SqlDelete tbl True_+++-- modifying commands++--from more tables+addFromTables :: [String] -> SqlCommand -> SqlCommand+addFromTables tbls cmd = cmd { tables = (tables cmd ++ tbls) }++-- projections, just defined for select+projectAttrs :: [String] -> SqlCommand -> SqlCommand+projectAttrs cols cmd = cmd {attrs = attrs cmd ++ cols}++projectJustAttrs :: [String] -> SqlCommand -> SqlCommand+projectJustAttrs cols cmd = cmd {attrs = cols}++countRows :: SqlCommand -> SqlCommand --just for select+countRows cmd = cmd {attrs = ["COUNT (*)"] }++-- restrictions, just defined for select, update and delete+restrictAttr :: String -> SqlValue -> SqlCommand -> SqlCommand+restrictAttr attr val = addCriterium (Const attr .==. Value val)++restrictAttrs :: [(String, SqlValue)] -> SqlCommand -> SqlCommand+restrictAttrs attrs cmd = foldr (uncurry restrictAttr) cmd attrs++restrictAttrsEqual :: String -> String -> SqlCommand -> SqlCommand+restrictAttrsEqual attr1 attr2 = addCriterium (Const attr1 .==. Const attr2)++restrictAttrInSubQuery :: (String, SqlCommand) -> SqlCommand -> SqlCommand+restrictAttrInSubQuery (attr, subq) = addCriterium (attr `in_` subq)++modWhere :: (SqlExp -> SqlExp) -> SqlCommand -> SqlCommand+modWhere f cmd = cmd {criteria = f (criteria cmd)}++setCriteria :: [SqlExp] -> SqlCommand -> SqlCommand+setCriteria constraints cmd = cmd {criteria = foldl (AppBinOp And_) True_ constraints }++addCriterium :: SqlExp -> SqlCommand -> SqlCommand+addCriterium crit = modWhere (\e-> AppBinOp And_ e crit)++-- order, limit and offset just defined for select+setOrderAsc, setSubOrderAsc, setOrderDesc, setSubOrderDesc :: String -> SqlCommand -> SqlCommand+setOrderAsc col cmd = cmd {order = (col, OrderAsc) : order cmd }+setOrderDesc col cmd = cmd {order = (col, OrderDesc) : order cmd }+setSubOrderAsc col cmd = cmd {order = order cmd ++ [(col, OrderAsc) ]}+setSubOrderDesc col cmd = cmd {order = order cmd ++ [(col, OrderDesc) ]}++setOrder, setSubOrder :: String -> OrderDirection -> SqlCommand -> SqlCommand+setOrder name OrderAsc = setOrderAsc name+setOrder name OrderDesc = setOrderDesc name+setSubOrder name OrderAsc = setSubOrderAsc name+setSubOrder name OrderDesc = setSubOrderDesc name++setOrderList :: [(String,OrderDirection)] -> SqlCommand -> SqlCommand+setOrderList [] cmd = cmd {order = []}+setOrderList ((name,dir): ordBy' ) cmd = foldl setSubOrder' (setOrder name dir cmd) ordBy'+ where setSubOrder' cmd (name,dir) = setSubOrder name dir cmd ++setLimit, setOffset :: Integer -> SqlCommand -> SqlCommand+setLimit i cmd = cmd {limit = Just i}+setOffset i cmd = cmd {offset = Just i}++setRange :: Integer -> Integer -> SqlCommand -> SqlCommand+setRange from to = setLimit (to-from) . setOffset from++-- setting values just defined for update and insert+setValue :: String -> SqlValue -> SqlCommand -> SqlCommand+setValue col val cmd = cmd{set=(col, Value val):set cmd }++setValues :: [(String,SqlValue)] -> SqlCommand -> SqlCommand+setValues vals cmd = foldr (uncurry setValue) cmd vals++-- setting returning field name just defined for insert+setReturning :: String -> SqlCommand -> SqlCommand+setReturning serial cmd = cmd {returning = Just serial}+++-- textual Searchs+--casesensitiveSearchExpr :: [String] -> String -> SqlExp+caseInsensitiveSearchExpr :: [String] -> String -> SqlExp+caseInsensitiveSearchExpr colsToLookIn s + = AnyCondition (map (`lowerLike` toSql ("%" ++ low s ++ "%")) colsToLookIn)+++{-+query1 = setOrderDesc "comment_id" $ restrictAttrs [("resource_id", toSql (1::Integer)), ("resource_type", toSql "person")] $ selectCmd "person"+query2 = countRows $ setLimit 10 $ setOffset 30 $ query1+query3 = setRange 15 20 query2+query4 = insertCmd "comment" [("id",toSql (3::Integer)), ("name", toSql "pipo")]+query5 = setReturning "comment_id" query4+query6 = updateCmd "comment" [("id",toSql (3::Integer)), ("name", toSql "pipo")]+query7 = restrictAttr "comment_id" (toSql(3::Integer)) query6+query8 = restrictAttrs [("id",toSql (3::Integer)), ("name", toSql "pipo")] $ deleteCmd "comment"++main = print $ ppSqlCommand query8++-}
+ RESTng/RESTngMonad.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module RESTng.RESTngMonad where++import Database.HDBC.PostgreSQL (connectPostgreSQL, Connection)+import qualified Database.HDBC as HDBC (handleSqlError, disconnect, catchSql)+import Control.Monad.Reader++import Network.HTTP.RedHandler (RqHandlerT, mapRqHandlerT)+import RESTng.Resources.User++-----------------------------------------------+-- the monad definition and running methods ---+-----------------------------------------------++newtype RESTng a = RESTng {unRESTng::ReaderT (Connection, Maybe User) IO a}+ deriving (Functor, Monad, MonadIO, MonadReader (Connection, Maybe User))+++runRESTng :: String -> RESTng a -> IO a+runRESTng connString m = HDBC.handleSqlError $ runRESTng' connString m++safeRunRESTng :: String -> (String -> a) -> RESTng a -> IO a+safeRunRESTng connString errHandl m = safeHandleSqlError errHandl $ runRESTng' connString m++safeRunRESTng' :: String -> RESTng a -> IO (Either String{-error msg-} a)+safeRunRESTng' connString m = safeHandleSqlError' $ runRESTng' connString m++runRESTng' :: String -> RESTng a -> IO a+runRESTng' connString m = do+ conn <- connectPostgreSQL connString+ result <- runReaderT (unRESTng m) (conn, Nothing)+-- HDBC.commit conn+ HDBC.disconnect conn+ return result++-------------------------------------------+-- methods that lift HDBC functionality ---+-------------------------------------------++liftHDBC_0 :: (Connection -> IO a) -> RESTng a+liftHDBC_0 f = fmap fst ask >>= \conn -> liftIO (f conn)++liftHDBC_1 :: (Connection -> a -> IO b) -> a -> RESTng b+liftHDBC_1 f a = fmap fst ask >>= \conn -> liftIO (f conn a)++liftHDBC_2 :: (Connection -> a -> b -> IO c) -> a -> b -> RESTng c+liftHDBC_2 f a b = fmap fst ask >>= \conn -> liftIO (f conn a b)++safeHandleSqlError :: (String -> a) -> IO a -> IO a+safeHandleSqlError errHandl action =+ HDBC.catchSql action handler+ where handler e = return $ errHandl ("SQL error: " ++ show e)++safeHandleSqlError' :: IO a -> IO (Either String{-error msg-} a)+safeHandleSqlError' action =+ HDBC.catchSql (action >>= return . Right) handler+ where handler e = return $ Left ("SQL error: " ++ show e)++--------------------------------------------------------------------------+-- methods that deal with the context info. (just the user currently) ----+--------------------------------------------------------------------------+getAuthUser :: RESTng (Maybe User)+getAuthUser = fmap snd ask++withAuthUser :: (Maybe User) -> RESTng a -> RESTng a+withAuthUser u = local (\(c,_)->(c,u))++authdUsername :: RESTng String+authdUsername = do authUser <- getAuthUser+ case authUser of+ Just u -> return $ username u+ Nothing -> return "Guest" --HOOKME++--------------------------------------------------------------------------+-- request handlers that use the database or context for the response ----+--------------------------------------------------------------------------+dbRqHandler :: String -> RqHandlerT RESTng a -> RqHandlerT IO a+dbRqHandler connString = mapRqHandlerT (runRESTng connString)++safeDbRqHandler :: String -> (String -> a) -> RqHandlerT RESTng a -> RqHandlerT IO a+safeDbRqHandler connString strhan = mapRqHandlerT $ safeRunRESTng connString (Just . strhan)
+ RESTng/Resources.hs view
@@ -0,0 +1,15 @@+module RESTng.Resources+ (+ module RESTng.Resources.User, userProxy,+ module RESTng.Resources.Comment,+ module RESTng.Resources.Rating,+ module RESTng.Resources.ResourceTag,+ ) where++import RESTng.Resources.User+import RESTng.Resources.UserModel (userProxy)+import RESTng.Resources.UserCRUD+import RESTng.Resources.Comment hiding (resource_id, resource_type)+import RESTng.Resources.Rating hiding (resource_id, resource_type)+import RESTng.Resources.ResourceTag hiding (resource_id, resource_type)+
+ RESTng/Resources/Comment.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}++module RESTng.Resources.Comment where++import Prelude hiding(span, div)+import Database.HDBC (toSql)+import Text.ParserCombinators.Parsec (parse)+import Data.Generics++import Text.CxML+import Network.HTTP.RedHandler (RequestContext, completeURL)++import RESTng.Database.Record+import RESTng.RESTngMonad (RESTng)+import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.PersistableResource+import RESTng.System.WebResource+import RESTng.System.Annotation+import RESTng.System.Permission (everybodyCan)+import RESTng.System.CRUD+import RESTng.System.Association+import RESTng.System.FormFields+import RESTng.System.Component (childComponent)++data Comment = Comment {+ comment_id :: Integer,+ comment_title :: String,+ comment_body :: String,+ resource_id :: Integer,+ resource_type :: String+ } deriving (Data, Typeable)++instance Resource Comment where+ resourceType _ = "Comment"+ key = comment_id+ setKey p k = p{comment_id = k}+ userFields _ = ["comment_title", "comment_body", "resource_id", "resource_type"]++--FIXME: ownable = True in the future since comments should have owner, I think.+-- Then, we could change CRUD permisssions for comments.+++instance RelationalResource Comment where+ tableName _ = "Comments"++ userFieldsToSql r = [ toSql $ comment_title r, toSql $ comment_body r,+ toSql $ resource_id r, toSql $ resource_type r ]+++-- sqlUserFieldsParser :: SystemFields -> SqlValueParser a+ sqlUserFieldsParser (k, _) = + do+ (ctitle, cbody, rid, rtype) <- sqlRecordParser+ return (Comment k ctitle cbody rid rtype)+++instance PersistableResource Comment where+ persistableFunctions = persistableFromRelational+++instance WebResource Comment where+ userFieldValues r = [ showField $ comment_title r, showField $ comment_body r,+ showField $ resource_id r, showField $ resource_type r ]++ userFieldValuesParser (k, _) =+ do+ ctitle <- parseNotEmpty "comment_title"+ cbody <- parseNotEmpty "comment_body"+ rid <- parseField "resource_id"+ rtype <- parseNotEmpty "resource_type"+ return (Comment k ctitle cbody rid rtype)++++instance InGridResource Comment++-- Comments CRUD+instance AnnotatedResource Comment++instance CRUDable Comment where+ canGetCreationForm = everybodyCan+ canCreate = everybodyCan+ canRetrieve = everybodyCan+ canUpdate = everybodyCan+ canDelete = everybodyCan+++-- Comment Annotations (for other resources)+commentProxy :: Proxy Comment+commentProxy = undefined++instance RelationalResource a => RelationalOneToMany a Comment where -- requires FlexibleInstances & MultiParamTypeClasses+ --fkValue :: Proxy a -> Comment -> Integer+ fkValue _ = resource_id+ fkName _ _ = "resource_id"++instance RelationalResource a => AssocOneToMany a Comment where -- requires FlexibleInstances & MultiParamTypeClasses+ polyDiscriminatorName _ _ = "resource_type"+ polyDiscriminator comm _ = resource_type comm+ oneToManyFunctions = oneToManyFromRelational+++comments :: AssocOneToMany a Comment => Annotation a+comments = (childComponent commentProxy) {whenListingElement = showCommentsQty}++showCommentsQty :: AssocOneToMany a Comment => a -> RESTng (CxML RequestContext)+showCommentsQty res+ = do commsQty <- findReferringTo res commentProxy >>= return . length+ return (withCtx $ urlLink commsQty)+ where+ urlLink commsQty rq = a!("href", completeURL rq) /- [t (show commsQty ++ " comments")]+--FIXME: make a select count query instead of calculating the length of the list of comments
+ RESTng/Resources/Rating.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}++module RESTng.Resources.Rating where++import Prelude hiding(span, div)+import Database.HDBC (toSql)+import Text.ParserCombinators.Parsec (parse)+import Data.List(intercalate)+import Data.Generics++import Text.CxML+import Network.HTTP.RedHandler (RequestContext, completeURL, addMethodNewToCollAddr, addHierarchicalCollToResAddr, renderQuery)++import RESTng.Database.SQL+import RESTng.Database.Record+import RESTng.RESTngMonad (RESTng, getAuthUser)+import RESTng.Resources.User (User)+import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.PersistableResource+import RESTng.System.WebResource+import RESTng.System.Annotation+import RESTng.System.Permission (everybodyCan, nobodyCan)+import RESTng.System.CRUD+import RESTng.System.Association+import RESTng.System.FormFields++data RatingVote = RatingVote {+ rating_vote_id :: Integer,+ owner_id :: Integer,+ resource_id :: Integer,+ resource_type :: String,+ value :: Integer+ } deriving (Data, Typeable)++instance Resource RatingVote where+ resourceType _ = "RatingVote"+ key = rating_vote_id+ setKey p k = p{rating_vote_id = k}++ ownable _ = True+ ownerId = owner_id+ setOwnerId oid r = r {owner_id = oid}+ ownerIdName _ = "user_id"+ userFields _ = ["resource_id", "resource_type", "value"]+++instance RelationalResource RatingVote where++ userFieldsToSql r = [ toSql $ resource_id r, toSql $ resource_type r,+ toSql $ value r ]++-- sqlUserFieldsParser :: SystemFields -> SqlValueParser a+ sqlUserFieldsParser (k, (Just oid)) = + do+ (rid, rtype, val) <- sqlRecordParser+ return (RatingVote k oid rid rtype val)+++instance PersistableResource RatingVote where+ persistableFunctions = persistableFromRelational++instance WebResource RatingVote where+ userFieldValues r = [ showField $ resource_id r, showField $ resource_type r,+ showField $ value r ]++ userFieldValuesParser (k, (Just oid)) = + do+ rid <- parseField "resource_id"+ rtype <- parseNotEmpty "resource_type"+ val <- parseField "value"+ return (RatingVote k oid rid rtype val)+++instance InGridResource RatingVote++-- RatingVote CRUD+instance AnnotatedResource RatingVote++instance CRUDable RatingVote where+ canGetCreationForm = everybodyCan+ canCreate = everybodyCan+ canRetrieve = nobodyCan+ canUpdate = nobodyCan+ canDelete = nobodyCan+--FIXME: change permission canGetCreationForm to nobodyCan (after some testing)++-- RatingVote Annotations+ratingVoteProxy :: Proxy RatingVote+ratingVoteProxy = undefined+++ratings :: AssocOneToMany a RatingVote => Annotation a+ratings = defaultAnnotation {+ annotationName = "ratings",+ whenShowingElement = showRating,+ whenEditingElement = showRating,+ whenListingElement = showRating+ }+++showRating :: AssocOneToMany a RatingVote => a -> RESTng (CxML RequestContext)+showRating res = do ratingVotes <- findReferringTo res ratingVoteProxy+ authUsr <- getAuthUser+ let (rate, rvsQty) = getAvgAndLength ratingVotes+ return ( (t $ showRate rate ++ showRatings rvsQty) ++++ (withCtx $ maybeNewLink authUsr)+ )+ where+ getAvgAndLength :: [RatingVote] -> (Maybe Float, Int)+ getAvgAndLength = avgAndLength . (map value)+ showRate Nothing = "Rated: not yet"+ showRate (Just r) = "Rated: " ++ show r+ showRatings rvsQty = " (" ++ show rvsQty ++" ratings" ++ ")"++ maybeNewLink :: Maybe User -> RequestContext -> CxML RequestContext+ maybeNewLink Nothing rq = a!("href", ("/login.html" ++ renderQuery [("kurl",completeURL rq)]))+ /- [t "(login to rate)"]+ maybeNewLink (Just u) rq = a!("href", newRatingVoteURL rq) /- [t "Please rate"]++ newRatingVoteURL = completeURL . newRatingVoteCtx+ newRatingVoteCtx :: RequestContext -> RequestContext+ newRatingVoteCtx = addMethodNewToCollAddr .+ addHierarchicalCollToResAddr (resourceType ratingVoteProxy) restQuery+ restQuery = referringQuery (proxyOf res) ratingVoteProxy (key res)+++-- |Although Fractional type have a representation for values coming from by 0 division+-- we choose to represent that case explicitely with a Nothing+avgAndLength :: (Fractional a, Integral b) => [b] -> (Maybe a, Int)+avgAndLength nums = (avg,l)+ where+ (s,l) = sumAndLength nums+ avg = if l==0 + then Nothing -- can not calculate avg if nobody has rated+ else Just (fromIntegral s / fromIntegral l)+++sumAndLength :: Num a => [a] -> (a,Int)+sumAndLength [] = (0,0)+sumAndLength (n:ns) = let (s,l) = sumAndLength ns+ in (s+n,l+1)++instance RelationalResource a => RelationalOneToMany a RatingVote where -- requires FlexibleInstances & MultiParamTypeClasses+ --fkValue :: Proxy a -> RatingVote -> Integer+ fkValue _ = resource_id+ fkName _ _ = "resource_id"++instance RelationalResource a => AssocOneToMany a RatingVote where -- requires FlexibleInstances & MultiParamTypeClasses+ polyDiscriminatorName _ _ = "resource_type"+ polyDiscriminator r _ = resource_type r+ oneToManyFunctions = oneToManyFromRelational+++-- helper functions to process rated resources:+projectAndOrderByRatingQuery :: RelationalResource a => Proxy a -> SqlCommand -> SqlCommand+projectAndOrderByRatingQuery pr selectQuery = + setOrderDesc "rating" $ projectAttrs ["sum(r.value)/count(*) as rating"] $+ restrictAttr "r.resource_type" (toSql "Article") $ restrictAttrsEqual (tableName pr ++ ".id") "r.resource_id" $+ addFromTables ["RatingVote r"] $ selectQuery {groupBy = attrs selectQuery}+++
+ RESTng/Resources/ResourceTag.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}++module RESTng.Resources.ResourceTag where++import Prelude hiding(span, div)+import Database.HDBC (toSql)+import Text.ParserCombinators.Parsec (parse)+import Data.List(intercalate)+import Data.Generics++import Text.CxML hiding(tag)+import Network.HTTP.RedHandler (RequestContext, completeURL, addMethodNewToCollAddr, addHierarchicalCollToResAddr)++import RESTng.Database.SQL+import RESTng.Database.Record+import RESTng.RESTngMonad (RESTng)+import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.PersistableResource+import RESTng.System.WebResource+import RESTng.System.Annotation+import RESTng.System.Permission (everybodyCan)+import RESTng.System.CRUD+import RESTng.System.Association+import RESTng.System.FormFields+++data ResourceTag = ResourceTag {+ resource_tag_id :: Integer,+ resource_id :: Integer,+ resource_type :: String,+ tag :: String+ } deriving (Data, Typeable)++instance Resource ResourceTag where+ resourceType _ = "ResourceTag"+ key = resource_tag_id+ setKey p k = p{resource_tag_id = k}++ userFields _ = ["resource_id", "resource_type", "tag"]+++instance RelationalResource ResourceTag where++ userFieldsToSql r = [ toSql $ resource_id r, toSql $ resource_type r,+ toSql $ tag r ]++-- sqlUserFieldsParser :: SystemFields -> SqlValueParser a+ sqlUserFieldsParser (k, _) = + do+ (rid, rtype, ta) <- sqlRecordParser+ return (ResourceTag k rid rtype ta)++instance PersistableResource ResourceTag where+ persistableFunctions = persistableFromRelational++instance WebResource ResourceTag where+ userFieldValues r = [ showField $ resource_id r, showField $ resource_type r,+ showField $ tag r ]++ userFieldValuesParser (k, _) =+ do+ rid <- parseField "resource_id"+ rtype <- parseNotEmpty "resource_type"+ ta <- parseNotEmpty "tag"+ return (ResourceTag k rid rtype ta)++ listElementHtml resTag = tr /- [td /- [tagLink resTag]]++--------------------------------+-- Pointing to tag resource ---+--------------------------------+tagLink :: ResourceTag -> CxML a+tagLink ta = tagLink' (tag ta) Nothing+--Note that the tag resource must be implemented at application level.+-- FIXME: implement read-only algorithmic resources +-- When doing this, the key for tags will be a string (pretty key) not an id!!!!++tagLink' :: String -> Maybe Integer -> CxML a+tagLink' name maybeQty = a!("href", "/Tag/" ++ name)+ /- [t $ name ++ maybeQtyDescription]+ where maybeQtyDescription = case maybeQty of+ Nothing -> ""+ Just qty -> "(" ++ show qty ++ ")"+++instance InGridResource ResourceTag++-- ResourceTag CRUD+instance AnnotatedResource ResourceTag++instance CRUDable ResourceTag where+ canGetCreationForm = everybodyCan+ canCreate = everybodyCan+ canRetrieve = everybodyCan+ canUpdate = everybodyCan+ canDelete = everybodyCan+--FIXME: change permission canGetCreationForm to nobodyCan (after some testing)++-- ResourceTag Annotations+resourceTagProxy :: Proxy ResourceTag+resourceTagProxy = undefined+++resourceTags :: AssocOneToMany a ResourceTag => Annotation a+resourceTags = defaultAnnotation {+ annotationName = "tags",+ whenShowingElement = showTags,+ whenEditingElement = showTags,+ whenListingElement = showTags+ }++showTags :: AssocOneToMany a ResourceTag => a -> RESTng (CxML RequestContext)+showTags res+ = do resTags <- findReferringTo res resourceTagProxy+ return (concatCxML (map tagLink resTags ++ [withCtx newTagLink]))++ where+ newTagLink rq = a!("href", newTagUrl rq) /- [t "Add tag"]+ newTagUrl = completeURL . addMethodNewToCollAddr . addHierarchicalCollToResAddr (resourceType resourceTagProxy) restQuery+ restQuery = referringQuery (proxyOf res) resourceTagProxy (key res)+++instance RelationalResource a => RelationalOneToMany a ResourceTag where -- requires FlexibleInstances & MultiParamTypeClasses+ --fkValue :: Proxy a -> ResourceTag -> Integer+ fkValue _ = resource_id+ fkName _ _ = "resource_id"++instance RelationalResource a => AssocOneToMany a ResourceTag where -- requires FlexibleInstances & MultiParamTypeClasses+ polyDiscriminatorName _ _ = "resource_type"+ polyDiscriminator r _ = resource_type r+ oneToManyFunctions = oneToManyFromRelational+++-- helper functions to process tagged resources:+restrictByTagQuery :: RelationalResource a => Proxy a -> String -> SqlCommand -> SqlCommand+restrictByTagQuery pr tagname selectQuery = restrictAttrInSubQuery (tableName pr ++ ".id" ,resourceIdsQuery) selectQuery+ where+ resourceIdsQuery :: SqlCommand+ resourceIdsQuery = projectJustAttrs ["DISTINCT resource_id"] $+ sqlSelect [("resource_type", resourceType pr),("tag",tagname)] [] resourceTagProxy+
+ RESTng/Resources/User.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveDataTypeable #-}++module RESTng.Resources.User where++import Data.Generics++data User = User {+ user_id :: Integer,+ username:: String,+ passwd:: String,+ roles :: [UserRole]+ } deriving (Show, Data, Typeable)++data UserRole = Admin | Normal deriving (Show, Read, Eq, Data, Typeable)+
+ RESTng/Resources/UserCRUD.hs view
@@ -0,0 +1,33 @@+module RESTng.Resources.UserCRUD where++import RESTng.Resources.User+import RESTng.System.WebResource+import RESTng.System.Annotation+import RESTng.System.Permission (onlyAdminCan)+import RESTng.System.CRUD+import RESTng.System.FormFields+++instance WebResource User where+ userFieldValues u = [showField $ username u, showField $ passwd u, showField $ roles u]++ -- userFieldValuesParser :: SystemFields -> AssocListValidator a+ userFieldValuesParser (k, _) =+ do+ name <- parseNotEmpty "username"+ pass <- parseNotEmpty "passwd"+ rls <- parseField "roles"+ return (User k name pass rls)++instance InGridResource User++instance AnnotatedResource User++instance CRUDable User+ where+ canGetCreationForm = onlyAdminCan+ canCreate = onlyAdminCan+ canRetrieve = onlyAdminCan+ canUpdate = onlyAdminCan+ canDelete = onlyAdminCan+
+ RESTng/Resources/UserModel.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}++module RESTng.Resources.UserModel where++import Database.HDBC (SqlType, toSql, fromSql)+import Text.ParserCombinators.Parsec (parse)+import Data.Maybe(fromMaybe)++import RESTng.Database.Record+import RESTng.Resources.User+import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.PersistableResource+import RESTng.System.FormFields++userProxy :: Proxy User+userProxy = undefined++instance SqlType [UserRole]+ where+ toSql = toSql . show+ fromSql = fromMaybe [] . readField . fromSql++instance Field [UserRole]+ where+ defaultValue = []++instance Resource User where+ key = user_id+ setKey p k = p{user_id = k}+ resourceType _ = "User"+ userFields _ = ["username", "passwd", "roles"]++--TODO: in case we want the User to edit+-- some of its attributes, then we should+-- made ownable _ = True, and the attribute must be the user_id field.++instance RelationalResource User where+ tableName _ = "Users"++ userFieldsToSql u = [toSql $ username u, toSql $ passwd u, toSql $ roles u]++-- sqlUserFieldsParser :: SystemFields -> SqlValueParser a+ sqlUserFieldsParser (k, _) = + do+ uname <- sqlFieldParser+ pass <- sqlFieldParser+ rls <- sqlFieldParser+ return (User k uname pass rls)++instance PersistableResource User where+ persistableFunctions = persistableFromRelational+
+ RESTng/RqHandlers.hs view
@@ -0,0 +1,11 @@+module RESTng.RqHandlers+ (+ module Network.HTTP.RedHandler,+ RESTngResp, okNonCxMLRsp, okNonCxMLStrRsp, htmlToCxML, restngRespToRsp, withTitle, okCxML,+ inGridWithElems, okBoxes, okBoxesM, -- from GridHandler+ ) where++import Network.HTTP.RedHandler+import RESTng.RqHandlers.GridHandler+import RESTng.RqHandlers.Response+
+ RESTng/RqHandlers/GridHandler.hs view
@@ -0,0 +1,29 @@+module RESTng.RqHandlers.GridHandler+ (+ inGridWithElems,+ okBoxes, okBoxesM+ )+where++import Control.Monad.Trans (lift)+import Control.Monad.Reader (ask)++import Text.YuiGrid+import Network.HTTP.RedHandler++import RESTng.RqHandlers.Response++inGridWithElems :: Monad m => [GridElement RequestContext] -> RqHandlerT m RESTngResp -> RqHandlerT m RESTngResp+inGridWithElems ges handl+ = do ges' <- fmap (runBoxes ges) ask+ fmap (modTitledRespBod (addGrdElems ges')) handl+ where+ addGrdElems ges' (CxMLResp c) = GridElems ([boxInMain c] ++ ges')+ addGrdElems ges' (GridElems bodyges) = GridElems (bodyges ++ ges')+++okBoxes :: Monad m => [GridElement RequestContext] -> RqHandlerT m RESTngResp+okBoxes bxs = fmap (okRspWithoutTitle . GridElems . runBoxes bxs) ask++okBoxesM :: Monad m => [m (GridElement RequestContext)] -> RqHandlerT m RESTngResp+okBoxesM mGrdElems = (lift $ sequence mGrdElems) >>= \grdElems -> okBoxes grdElems
+ RESTng/RqHandlers/Response.hs view
@@ -0,0 +1,66 @@+module RESTng.RqHandlers.Response where++import Data.List(intercalate)+import Text.XHtml.Strict+import Control.Monad.Reader (ask)++import qualified Text.CxML as Cx+import Text.YuiGrid+import Network.HTTP.RedHandler++import RESTng.Utils (mapFst, mapSnd)+------------------------------------------------------------------+--------- Handler response types and combinators -----------------+------------------------------------------------------------------++type RESTngTitledRespBody = ([String], RESTngRespBody)+data RESTngRespBody =+ CxMLResp (Cx.NonCxML)+ | GridElems [GridElement ()]+++type RESTngResp = HandlerRsp RESTngTitledRespBody++restngRespToRsp :: RESTngResp -> BasicRsp+restngRespToRsp = basicRspWith titledRespBodyToString++titledRespBodyToString :: RESTngTitledRespBody -> String+titledRespBodyToString (titlParts, bod) + = Cx.showNonCxmlStrict fullTitle cxmlBod+ where+ cxmlBod = case bod of+ GridElems gs -> gridPage gs+ CxMLResp cx -> cx+ fullTitle = intercalate " | " $ filter (not . null) titlParts -- HOOKME+++withTitle :: Monad m => String -> RqHandlerT m (HandlerRsp ([String], a)) -> RqHandlerT m (HandlerRsp ([String], a))+withTitle t = fmap (addTitleToResp t)+++-- combinators for responses with title+addTitleToResp :: String -> HandlerRsp ([String], a) -> HandlerRsp ([String], a)+addTitleToResp t resp = fmap (mapFst ((:) t)) resp++modTitledRespBod :: (a -> b) -> HandlerRsp ([String], a) -> HandlerRsp ([String], b)+modTitledRespBod f m = fmap (mapSnd f) m++--Response creation combinators+okRspWithTitle :: String -> a -> HandlerRsp ([String], a)+okRspWithTitle s x = return ([s], x)++okRspWithoutTitle :: a -> HandlerRsp ([String], a)+okRspWithoutTitle x = return ([], x)++okNonCxMLRsp :: Cx.NonCxML -> RESTngResp+okNonCxMLRsp = okRspWithoutTitle . CxMLResp++okNonCxMLStrRsp :: String -> RESTngResp+okNonCxMLStrRsp s = okRspWithTitle s (CxMLResp (Cx.h1 Cx./- [Cx.t s]))++okCxML :: Monad m => Cx.CxML RequestContext -> RqHandlerT m RESTngResp+okCxML cx = fmap (okNonCxMLRsp . Cx.runCxML cx) ask++htmlToCxML :: Html -> Cx.NonCxML+htmlToCxML = Cx.t . prettyHtmlFragment+
+ RESTng/System.hs view
@@ -0,0 +1,45 @@+module RESTng.System+ (+ module RESTng.Database.Record,+ module RESTng.Database.SQL,+ module RESTng.Resources.User,+ module RESTng.RESTngMonad,+ module RESTng.System.Proxy,+ module RESTng.System.Resource,+ module RESTng.System.RelationalResource,+ module RESTng.System.ORMTypesConv,+ module RESTng.System.ORM,+ module RESTng.System.PersistableResource,+ module RESTng.System.WebResource,+ module RESTng.System.CRUD,++ module RESTng.System.FormFields,+ module RESTng.System.Annotation,+ module RESTng.System.Permission,+ module RESTng.System.Association,+ module RESTng.System.Component,+ module RESTng.System.Authentication,+ ) where++import RESTng.Database.Record+import RESTng.Database.SQL+import RESTng.Resources.User+import RESTng.RESTngMonad+import RESTng.System.Proxy+import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.ORMTypesConv+import RESTng.System.ORM+import RESTng.System.PersistableResource+import RESTng.System.WebResource+import RESTng.System.CRUD++import RESTng.System.FormFields+-- FIXME: hide validation monad internals here++import RESTng.System.Annotation+import RESTng.System.Permission (everybodyCan)+import RESTng.System.Association+import RESTng.System.Component (parentComponent, referredThroughJoinComponent, childComponent, ParentBox(..), parentListComponent)+import RESTng.System.Authentication (anyLoginHandler, afterSettingAuthUser)+
+ RESTng/System/Annotation.hs view
@@ -0,0 +1,91 @@+module RESTng.System.Annotation where++import Control.Monad (liftM2)++import Text.CxML (CxML, (+++), t, noElem)+import Text.YuiGrid (GridElement, boxInMain, HasLayoutHints, modLayoutHints)++import Network.HTTP.RedHandler (RequestContext)+import RESTng.RESTngMonad (RESTng)+import RESTng.System.Resource(Resource, Proxy)++data Annotation a = Annotation {+ annotationName :: String,++ whenShowingElement :: a -> RESTng (CxML RequestContext),+ whenShowingElementLayout :: CxML RequestContext -> GridElement RequestContext,++ whenEditingElement :: a -> RESTng (CxML RequestContext),+ whenEditingElementLayout :: CxML RequestContext -> GridElement RequestContext,++ whenCreatingElement :: Proxy a -> RESTng (CxML RequestContext),+ whenCreatingElementLayout :: CxML RequestContext -> GridElement RequestContext,++ whenListingElement :: a -> RESTng (CxML RequestContext),+ whenListingElementLayout :: CxML RequestContext -> GridElement RequestContext+ }++whenShowingElementAnn :: Annotation a -> a -> RESTng (String, GridElement RequestContext)+whenShowingElementAnn ann res = whenShowingElement ann res >>= \cxml -> return (annotationName ann, whenShowingElementLayout ann cxml)++whenEditingElementAnn :: Annotation a -> a -> RESTng (String, GridElement RequestContext)+whenEditingElementAnn ann res = whenEditingElement ann res >>= \cxml -> return (annotationName ann, whenEditingElementLayout ann cxml)++whenCreatingElementAnn :: Annotation a -> Proxy a -> RESTng (String, GridElement RequestContext)+whenCreatingElementAnn ann pres = whenCreatingElement ann pres >>= \cxml -> return (annotationName ann, whenCreatingElementLayout ann cxml)++whenListingElementAnn :: Annotation a -> a -> RESTng (String, GridElement RequestContext)+whenListingElementAnn ann res = whenListingElement ann res >>= \cxml -> return (annotationName ann, whenListingElementLayout ann cxml)+++defaultAnnotation = Annotation {+ annotationName = "",++ whenShowingElement = blankAnnFunction,+ whenShowingElementLayout = boxInMain,++ whenEditingElement = blankAnnFunction,+ whenEditingElementLayout = boxInMain,++ whenCreatingElement = blankAnnFunction,+ whenCreatingElementLayout = boxInMain,++ whenListingElement = blankAnnFunction,+ whenListingElementLayout = boxInMain+ }++blankAnnFunction :: b -> RESTng (CxML RequestContext)+blankAnnFunction _ = return noElem++dummyStringAnnotation str+ = defaultAnnotation { + whenShowingElement = dummyStringAnnFunction str,+ whenEditingElement = dummyStringAnnFunction str,+ whenCreatingElement = dummyStringAnnFunction str,+ whenListingElement = dummyStringAnnFunction str+ }++dummyStringAnnFunction str _ = return $ t str++absorveAnn :: Annotation a -> Annotation a -> Annotation a+ann1 `absorveAnn` ann2 = ann1 { + whenShowingElement = \res -> liftM2 (+++) (whenShowingElement ann1 res) (whenShowingElement ann2 res),+ whenEditingElement = \res -> liftM2 (+++) (whenEditingElement ann1 res) (whenEditingElement ann2 res),+ whenCreatingElement = \res -> liftM2 (+++) (whenCreatingElement ann1 res) (whenCreatingElement ann2 res),+ whenListingElement = \res -> liftM2 (+++) (whenListingElement ann1 res) (whenListingElement ann2 res)+ }++class Resource a => AnnotatedResource a where+ annotations :: [Annotation a]+ annotations = []++instance HasLayoutHints (Annotation a) where+ --modLayoutHints :: (LayoutHints -> LayoutHints) -> Annotation a -> Annotation a+ modLayoutHints f ann = ann {+ whenShowingElementLayout = f' . whenShowingElementLayout ann,+ whenEditingElementLayout = f' . whenEditingElementLayout ann,+ whenCreatingElementLayout = f' . whenCreatingElementLayout ann,+ whenListingElementLayout = f' . whenListingElementLayout ann+ }+ where f' = modLayoutHints f+
+ RESTng/System/Association.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS -fallow-undecidable-instances #-}++module RESTng.System.Association where++import Database.HDBC (toSql)+import RESTng.RESTngMonad (RESTng, liftHDBC_0)+import RESTng.Database.SQL (restrictAttr)+import RESTng.Database.Record++import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.PersistableResource++class Resource a => AssocOneToMany a b where+ polyDiscriminatorName :: Proxy a -> Proxy b -> String+ polyDiscriminatorName _ _ = ""+ polyDiscriminator :: b -> Proxy a -> String+ --FIXME: this looks like depending only on the children type (not the parent)+ -- for instance, comments associated with different resources types. polyDiscriminator = resource_type++ -- if this String == "" means that it is not a polymorphic association+ findReferredBy :: b -> Proxy a -> RESTng (Maybe a) -- b has the foreing key in one to many+ findReferringTo :: a -> Proxy b -> RESTng [b]+ referringQuery :: Proxy a -> Proxy b -> Integer -> [(String,String)] -- TODO: document this++ oneToManyFunctions :: (+ b -> Proxy a -> RESTng (Maybe a), -- findReferredBy+ a -> Proxy b -> RESTng [b], -- findReferringTo+ Proxy a -> Proxy b -> Integer -> [(String,String)]+ )++ oneToManyFunctions = (findReferredBy, findReferringTo, referringQuery)+ findReferredBy = fst3 oneToManyFunctions+ findReferringTo = snd3 oneToManyFunctions+ referringQuery = trd3 oneToManyFunctions++isPolimorphicAssociation :: AssocOneToMany a b => Proxy a -> Proxy b -> Bool+isPolimorphicAssociation pa pb = (not . null) $ polyDiscriminatorName pa pb++isAssociatedToType :: (Resource a, AssocOneToMany a b) => b -> Proxy a -> Bool+isAssociatedToType b pa = not (isPolimorphicAssociation pa pb) || (polyDiscriminator b pa == resourceType pa)+ where pb = proxyOf b+++----------------------------------------------------------------+-- helpers to create associations from RelationalOneToMany -----+----------------------------------------------------------------++oneToManyFromRelational :: (AssocOneToMany a b, RelationalOneToMany a b, RelationalResource b) =>+ (+ b -> Proxy a -> RESTng (Maybe a), -- findReferredBy+ a -> Proxy b -> RESTng [b], -- findReferringTo+ Proxy a -> Proxy b -> Integer -> [(String,String)]+ )++oneToManyFromRelational = (r_findReferredBy, r_findReferringTo, r_referringQuery)++r_findReferredBy :: (AssocOneToMany a b, RelationalOneToMany a b) => b -> Proxy a -> RESTng (Maybe a) -- b has the foreing key in one to many+r_findReferredBy b pa = if (isAssociatedToType b pa)+ then liftHDBC_0 $ dbSelectOne k pa+ else return Nothing -- not of the correct type of children+ where+ k = (fkValue pa b)++r_findReferringTo :: (AssocOneToMany a b, RelationalOneToMany a b, RelationalResource b) => a -> Proxy b -> RESTng [b]+r_findReferringTo a pb = liftHDBC_0 $ runQueryN sqlRecordParser sqlCmd+ where+ sqlCmd = if (isPolimorphicAssociation pa pb)+ then restrictAttr (polyDiscriminatorName pa pb) (toSql (resourceType pa)) $ cmdSelectByFK+ else cmdSelectByFK++ cmdSelectByFK = sqlSelectByFK a pb+ pa = proxyOf a+++r_referringQuery :: (AssocOneToMany a b, RelationalOneToMany a b, RelationalResource b) => Proxy a -> Proxy b -> Integer -> [(String,String)]+r_referringQuery pa pb ix = if (isPolimorphicAssociation pa pb)+ then [(polyDiscriminatorName pa pb, resourceType pa), (fkName pa pb, show ix)]+ else [(fkName pa pb, show ix)]++----------------------------------------------------------------+-- utility functions+----------------------------------------------------------------++fst3 (x,y,z) = x+snd3 (x,y,z) = y+trd3 (x,y,z) = z+++{-+--------------------------------------------------------+-- associated predicate (for any two resources) --------+-- has to be tested on proxies -------------------------+--------------------------------------------------------++class AssocOneToManyP a b where+ isAssociated :: Proxy a -> Proxy b -> Bool+ isAssociated _ _ = True++instance AssocOneToManyP a b where isAssociated _ _ = False+--instance AssocOneToMany a b => AssocOneToManyP (Proxy a) (Proxy b) where isAssociated _ _ = True+-}
+ RESTng/System/Authentication.hs view
@@ -0,0 +1,132 @@+module RESTng.System.Authentication+ ( withAuthentication,+ afterSettingAuthUser,+ anyLoginHandler+ ) where+++import Prelude hiding(span, div)+import Control.Monad.Trans (liftIO, lift)+import Control.Monad.Reader (ask)++import Network.HTTP.RedHandler.Session+import Text.CxML+import RESTng.RESTngMonad (RESTng, getAuthUser, withAuthUser)+import RESTng.RqHandlers+import RESTng.System.PersistableResource (find, select01)+import RESTng.Resources.User+import RESTng.Resources.UserModel (userProxy)+++cookieName = "rnAuth"+ +-- example_credentials="webmaster:zrma4v" ; from http pocket ref example (note error in book - see online errata)+--encB64 s = B64.encode $ map (fromIntegral . ord) s+--decB64 s = map (chr . fromIntegral) $ B64.decode s++authenticateBasicHttp :: RequestContext -> RESTng (Maybe User)+authenticateBasicHttp rc = return Nothing++authenticateSession :: RequestContext -> RESTng (Maybe User)+authenticateSession rc = do maybeUserId <- liftIO $ getSessionedStateWithCookie cookieName rc+ case maybeUserId of+ Nothing -> return Nothing+ Just uid -> find uid userProxy+--FIXME: do something if the user does not exist (find returns nothing).+-- It is possible if the user has been deleted recently.++authenticate :: RequestContext -> RESTng (Maybe User)+authenticate rc = do auth1 <- authenticateBasicHttp rc+ case auth1 of+ Nothing -> authenticateSession rc+ _ -> return auth1+++afterSettingAuthUser :: RqHandlerT RESTng a -> RqHandlerT RESTng a+afterSettingAuthUser han = do rc <- ask+ authUsr <- lift (authenticate rc)+ mapRqHandlerT (withAuthUser authUsr) han+++-- If the authUser has not been set. and the credentials are ok, then this function set it.+-- After that, if the authentication is successful continue with the handler argument+-- otherwise continue with the login page (with the url for continuation encoded)+withAuthentication, withAuthentication' :: RqHandlerT RESTng RESTngResp -> RqHandlerT RESTng RESTngResp+withAuthentication = afterSettingAuthUser . withAuthentication'++withAuthentication' han = do authUsr <- lift getAuthUser+ case authUsr of+ Nothing -> getLoginHandler'+ _ -> han+++getLoginHandler :: Monad m => RqHandlerT m RESTngResp+getLoginHandler = ifGet $ withDocName "login" $ getLoginHandler'++getLoginHandler' :: Monad m => RqHandlerT m RESTngResp+getLoginHandler' = okCxML $ withCtx loginForm+++loginForm :: RequestContext -> CxML a+loginForm rq+ = form!("method","post")!("action","/login.html") + /- [br, + showField "username", + showField "password", + hideField "kurl" kurl,+ button!("name","action")!("value","submit") /- [t "Submit"] ]+ where+ showField :: String -> CxML a+ showField s = concatCxML [span /- [t s], textfield s, br ]+ hideField name val = span /- [hidden name val, br ]+ kurl = if (docName rq /= "login")+ then completeURL rq+ else -- we should redirect the output only if specified in the query parameters, otherwise set kurl to ""+ case lookup "kurl" $ query rq of+ Nothing -> ""+ Just url -> url+++postLoginHandler :: RqHandlerT RESTng RESTngResp+postLoginHandler = ifPost $ withDocName "login" $ withPostFields $ \pfs -> postLoginHandler' (map snd pfs)+ where+ postLoginHandler' (uname: pass: kurl: _ ) = processLogin uname pass kurl+ postLoginHandler' _ = failedLoginHandler++processLogin :: String -> String -> String -> RqHandlerT RESTng RESTngResp+processLogin uname pass kurl =+ do maybeUser <- lift $ select01 [("username", uname)] userProxy+ case maybeUser of+ Nothing -> failedLoginHandler+ Just u -> if isValidPass u pass+ then succededLoginHandler (user_id u) kurl+ else failedLoginHandler+ where+ isValidPass u pass = passwd u == pass++failedLoginHandler :: Monad m => RqHandlerT m RESTngResp+failedLoginHandler = return $ okNonCxMLStrRsp "Login Failed"++succededLoginHandler :: Integer -> String -> RqHandlerT RESTng RESTngResp+succededLoginHandler uid k = do setCookieFunc <- liftIO $ newSessionedStateWithCookie cookieName uid+ fmap setCookieFunc (maybeRedirectHandler k)+ where+ maybeRedirectHandler :: String -> RqHandlerT RESTng RESTngResp+ -- redirect or say hello+ maybeRedirectHandler [] = return $ okNonCxMLStrRsp "Welcome!"+ maybeRedirectHandler k = return $ redirectToRsp k+++logoutHandler :: RqHandlerT RESTng RESTngResp+logoutHandler = withDocName "logout" $ processLogoutHandler+++processLogoutHandler :: RqHandlerT RESTng RESTngResp+processLogoutHandler = do rqCtx <- ask+ setCookieFunc <- liftIO $ deleteSessionedStateWithCookie cookieName rqCtx+ fmap setCookieFunc (return $ okNonCxMLStrRsp "GoodBye")+-- should be just post? or a get, being transformed in a post like in the delete?+-- should remove the user from the ctx++anyLoginHandler = anyOf [getLoginHandler, postLoginHandler, logoutHandler]+
+ RESTng/System/CRUD.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-}+{-# OPTIONS_GHC -fglasgow-exts #-}++module RESTng.System.CRUD where++import Prelude hiding (div)+import Control.Monad (filterM)+import Control.Monad.Reader (ask)++import Text.CxML+import Text.YuiGrid (GridElement, toBox, toContainer)+import Control.Monad.Trans (lift)++import RESTng.Utils(low, lookupByFun, mapSnd)+import RESTng.RESTngMonad (RESTng, getAuthUser)+import RESTng.Database.SQL (OrderDirection)+import RESTng.RqHandlers+import RESTng.System.Resource+import RESTng.System.PersistableResource+import RESTng.System.WebResource+import RESTng.System.FormFields+import RESTng.System.Permission (Permission, checkPermissions, ownerOrAdminCan, everybodyCan, authdCan, allowedForUser)+import RESTng.System.Authentication (afterSettingAuthUser)+import RESTng.System.Annotation+import RESTng.System.Association+import RESTng.Resources.User(user_id, User)++-- this data type is to be used by the user.+--data CRUDableOneToManyBox = forall a. (CRUDable a) => C1toNB (Proxy a) (CRUDableChildOf a)++-- the CRUDableResBox is used by the handlers. A list of CRUDableResBox is created from a list of CRUDableOneToManyBox+data CRUDableChildOf a = forall b. (CRUDable b, AssocOneToMany a b) => CCB (Proxy b)++data CRUDableResBox = forall a. (CRUDable a) => CB+ (Proxy a) -- proxy+ [CRUDableChildOf a] -- childrenOf++lookupAssocByResType :: String -> [CRUDableResBox] -> Maybe CRUDableResBox+lookupAssocByResType resTypeName resList = lookupByFun boxResourceType resTypeName resList+ where+ boxResourceType :: CRUDableResBox -> String+ boxResourceType (CB p children) = low $ resourceType p+++lookupChildByResType :: CRUDable a => String -> [CRUDableChildOf a] -> Maybe (CRUDableChildOf a)+lookupChildByResType resTypeName resList = lookupByFun childResourceType resTypeName resList+ where+ childResourceType :: CRUDableChildOf a -> String+ childResourceType (CCB pb) = low $ resourceType pb+++class (InGridResource a, PersistableResource a, AnnotatedResource a) => CRUDable a where+ canGetCreationForm :: Permission a -- should not depend on the resource (since is undefined)+ canCreate :: Permission a+ canRetrieve :: Permission a+ canUpdate :: Permission a+ canDelete :: Permission a++ canGetCreationForm = authdCan+ canCreate = ownerOrAdminCan+ canRetrieve = everybodyCan+ canUpdate = ownerOrAdminCan+ canDelete = ownerOrAdminCan+++-- Handlers for CRUDs ++resourcesHandler :: [CRUDableResBox] -> RqHandlerT RESTng RESTngResp+resourcesHandler resList = underString (\resTypeName -> resourcesHandler' resTypeName resList)++resourcesHandler' :: String -> [CRUDableResBox] -> RqHandlerT RESTng RESTngResp+resourcesHandler' resTypeName resList =+ case maybeProxyAndAssoc of+ Nothing -> notMe+ Just (CB p children) -> + anyOf [+ resHandler' p,+ maybeChildHandler resList p children+ ]+ where+ maybeProxyAndAssoc = lookupAssocByResType resTypeName resList+++maybeChildHandler :: CRUDable a => [CRUDableResBox] -> Proxy a -> [CRUDableChildOf a] -> RqHandlerT RESTng RESTngResp+maybeChildHandler resList parentProxy children = + underInteger (\ix-> underString (\childName -> maybeChildHandler' resList parentProxy children ix childName ))+++maybeChildHandler' :: CRUDable a => [CRUDableResBox] -> Proxy a -> [CRUDableChildOf a] -> Integer -> String -> RqHandlerT RESTng RESTngResp+maybeChildHandler' resList pa children i childName = + case maybeChild of+-- Nothing -> sendStr (resourceType pa ++ " is NOT associated to " ++ childrenName) +-- Just (CCB pb) -> sendStr (resourceType pa ++ " is associated to " ++ resourceType pb)+ Nothing -> notMe+ Just (CCB pb) -> childHandler resList pa pb i++ where+ --maybeChild :: CRUDable a => Maybe (CRUDableChildOf a)+ maybeChild = lookupChildByResType childName children++childHandler :: (CRUDable a, CRUDable b, AssocOneToMany a b) => [CRUDableResBox] -> Proxy a -> Proxy b -> Integer -> RqHandlerT RESTng RESTngResp+childHandler resList pa pb ix+ = modReq setQueriesForChild $ resourcesHandler' (low $ resourceType pb) resList+ where+ setQueriesForChild :: RequestContext -> RequestContext+ setQueriesForChild = upgradeQueriesForHierarchy (referringQuery pa pb ix)++resHandler :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandler pa = under (resourceType pa) $ resHandler' pa++resHandler' :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandler' pa = withTitle (resourceType pa) $ afterSettingAuthUser $+ anyOf [+ ifGet $ anyOf [resHandlerList pa, resHandlerShow pa, resHandlerEdit pa, resHandlerNew pa],+ ifPost $ anyOf [resHandlerUpdate pa, resHandlerInsert pa, resHandlerDelete pa]+ ]++-- handlers for specific methods on a resource or resource collection+resHandlerList :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerShow :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerEdit :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerNew :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerUpdate :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerInsert :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerDelete :: CRUDable a => Proxy a -> RqHandlerT RESTng RESTngResp+++----------------------------------------------+--------- GET REQUEST HANDLERS ---------------+----------------------------------------------++resHandlerList pa = withDocName "index" $ withQuery $ resHandlerList' pa++-- They assume that we are ready for the db transaction/query +-- (i.e. the objects used as argument (maybe) have been built)+resHandlerList' :: CRUDable a => Proxy a -> [(String,String)] -> RqHandlerT RESTng RESTngResp+resHandlerList' pa queryPairs =+ do rs <- lift (select (filterFields queryPairs) [] pa)+ u <- lift getAuthUser+ allowed <- lift $ filterM (\r-> allowedForUser r canRetrieve) rs+ rAndAnnsList <- lift $ (sequence $ map rAndAnnsPair allowed)+ okBoxes (listView rAndAnnsList)++ where filterFields = filter (\(key,_) -> elem key (userFieldsWithKey pa))+ rAndAnnsPair :: AnnotatedResource a => a -> RESTng (a,[(String, GridElement RequestContext)])+ rAndAnnsPair r = do anns <- sequence $ map (listingAnnotation r) annotations+ return (r,anns)+ listingAnnotation :: Resource a => a -> Annotation a -> RESTng (String, GridElement RequestContext)+ listingAnnotation r ann = do cxml <- whenListingElement ann r >>= return . (inElementCtx r)+ return (annotationName ann, whenListingElementLayout ann cxml)+ inElementCtx r = modCx (addResourceIdToCollAddr (show $ key r))+--Should the filterFields protection go in the persistable or relational resource files?+-- would be safer, but could impose double traversing if the query list needs to be traversed here in the future+--FIXME:: filter the list like in GridCRUD?+++resHandlerShow pa = withDocNameInteger (\ix-> resHandlerShow' ix pa)++resHandlerShow' :: CRUDable a => Integer -> Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerShow' k pa =+ do maybeRecord <- lift $ find k pa+ case maybeRecord of+ Nothing -> notMe+ Just res -> (checkPermissions [canRetrieve] res $ resHandlerShowWithAnn res)+++resHandlerShowWithAnn :: CRUDable a => a -> RqHandlerT RESTng RESTngResp+resHandlerShowWithAnn res =+ do anns <- lift $ resShowingAnnotations res+-- catResps showReq (showingResourceAndHtmls res anns)+-- the line was put for debugging but did not work. maybe caResps is buggy.+ okBoxes (showView res anns)+++++resHandlerEdit pa = underInteger (\ix-> withDocName "edit" $ resHandlerEdit' ix pa Nothing)++resHandlerEdit' :: CRUDable a => Integer -> Proxy a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp+resHandlerEdit' k pa maybeErrs =+ do maybeRecord <- lift $ find k pa+ case maybeRecord of+ Nothing -> notMe+ Just res -> (checkPermissions [canRetrieve, canUpdate] res $ resHandlerEditWithAnn res maybeErrs)++resHandlerEditWithAnn :: CRUDable a => a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp+resHandlerEditWithAnn res maybeErrs =+ do anns <- lift $ resEditionAnnotations res+ okBoxes (editLayout (proxyOf res) renderedForm (maybeValErrsBox ++ anns))+ where+ (renderedForm,maybeValErrsBox) + = case maybeErrs of+ Nothing -> (formEditHtml res,[])+ Just (fields, valErrs) -> mapSnd ( (:[]) . (,) "valErrors" . toBox) $ + formAndErrorsCxMLs (proxyOf res) fields valErrs+++resHandlerNew pa = withDocName "new" $ (resHandlerNew' pa Nothing)++resHandlerNew' :: CRUDable a => Proxy a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp+resHandlerNew' pres maybeErrs = (checkPermissions permissions res $ resHandlerNewWithAnn pres maybeErrs)+ where+ res = fromProxy pres+ fromProxy :: Proxy a -> a+ fromProxy _ = undefined+--FIXME: can this trick with types be avoid?+ permissions = -- check if ownerId has to be enforced for this resource type and require authentication+ if (ownable pres) then [authdCan, canGetCreationForm]+ else [canGetCreationForm]++resHandlerNewWithAnn :: CRUDable a => Proxy a -> Maybe ([(String,String)], [(String,ValidationError)]) -> RqHandlerT RESTng RESTngResp+resHandlerNewWithAnn pres maybeErrs =+ do anns <- lift $ resCreationAnnotations pres+ okBoxes (createLayout pres renderedForm (maybeValErrsBox ++ anns))+ where+ (renderedForm,maybeValErrsBox) + = case maybeErrs of+ Nothing -> (formCreateHtml pres,[])+ Just (fields, valErrs) -> mapSnd ( (:[]) . (,) "valErrors" . toBox) $ + formAndErrorsCxMLs pres fields valErrs++----------------------------------------------+--------- POST REQUEST HANDLERS --------------+----------------------------------------------++resHandlerUpdate pr = underInteger (\ix-> withDocName "edit" $ withPostFields (resHandlerUpdate' pr ix))++resHandlerUpdate' :: CRUDable a => Proxy a -> Integer -> AssocList -> RqHandlerT RESTng RESTngResp+resHandlerUpdate' pr ix fs+ = processValidationOutput (runWebParserAndValidator pr (systemFieldsForUpdate ix) fs)+ where+ processValidationOutput :: CRUDable a => Either [(String, ValidationError)] a -> RqHandlerT RESTng RESTngResp+ processValidationOutput (Right res) = updateIfAllowed res+ processValidationOutput (Left valErrs) = resHandlerEdit' ix pr (Just (fs,valErrs))+++updateIfAllowed :: CRUDable a => a -> RqHandlerT RESTng RESTngResp+updateIfAllowed res = checkPermissions [canUpdate] res (update' res)+ where+ update' :: CRUDable a => a -> RqHandlerT RESTng RESTngResp+ update' res = lift (update res) >> showingResource res++systemFieldsForUpdate :: Integer -> SystemFields+systemFieldsForUpdate ix = (ix, Just 0)+-- FIXME: this is not the correct owner. Should we read the record from the db to check permissions?. +-- Logged in https://www.bugwiki.com/showBug.php?bug=1701+++resHandlerInsert pr = withDocName "new" $ withPostFields (resHandlerInsert' pr)++resHandlerInsert' :: CRUDable a => Proxy a -> AssocList -> RqHandlerT RESTng RESTngResp+resHandlerInsert' pr fs = do u <- lift getAuthUser+ processValidationOutput (runWebParserAndValidator pr (systemFieldsForInsert pr u) fs)+ where+ processValidationOutput :: CRUDable a => Either [(String,ValidationError)] a -> RqHandlerT RESTng RESTngResp+ processValidationOutput (Right res) = insertIfAllowed res+ processValidationOutput (Left valErrs) = resHandlerNew' pr (Just (fs,valErrs))+++insertIfAllowed :: CRUDable a => a -> RqHandlerT RESTng RESTngResp+insertIfAllowed res = -- check if ownerId has to be enforced for this resource type+ if (ownable $ proxyOf res)+ then checkPermissions [authdCan, canCreate] res (insert' res)+ else checkPermissions [canCreate] res (insert' res)+ where+ insert' :: CRUDable a => a -> RqHandlerT RESTng RESTngResp+ insert' res = do resWithKey <- lift $ insert res+ showingResource resWithKey++systemFieldsForInsert :: Resource a => Proxy a -> Maybe User -> SystemFields+systemFieldsForInsert pr u = (0, maybeOwnerId)+ where+ maybeOwnerId = if ownable pr+ then fmap user_id u -- map user_id in the Maybe Monad+ else Nothing++++resHandlerDelete pa = underInteger (\ix-> withDocName "delete" $ resHandlerDelete' ix pa)++resHandlerDelete' :: CRUDable a => Integer -> Proxy a -> RqHandlerT RESTng RESTngResp+resHandlerDelete' k pa =+ do maybeRecord <- lift $ find k pa+ case maybeRecord of+ Nothing -> fmap (okNonCxMLRsp . htmlToCxML . showReq) ask+ Just res -> checkPermissions [canDelete] res delete'+ where+ delete' :: RqHandlerT RESTng RESTngResp+ delete' = lift (delete k pa) >> listFilteredByQuery+ listFilteredByQuery = withQuery $ resHandlerList' pa+++----------------------------------------------+---- other utility request handlers ----------+----------------------------------------------+resListingAnnotations :: AnnotatedResource a => a -> RESTng [(String, GridElement RequestContext)]+resListingAnnotations res = sequence $ map (`whenListingElementAnn` res) annotations+-- TODO: look how the context must be set for this one. +-- After done, refactor code in listingResource and change to reuse this.++resShowingAnnotations :: AnnotatedResource a => a -> RESTng [(String, GridElement RequestContext)]+resShowingAnnotations res = sequence $ map (`whenShowingElementAnn` res) annotations++resEditionAnnotations :: AnnotatedResource a => a -> RESTng [(String, GridElement RequestContext)]+resEditionAnnotations res = sequence $ map (`whenEditingElementAnn` res) annotations++resCreationAnnotations :: AnnotatedResource a => Proxy a -> RESTng [(String, GridElement RequestContext)]+resCreationAnnotations pr = sequence $ map (`whenCreatingElementAnn` pr) annotations++++showingResource :: (PersistableResource a, WebResource a) => a -> RqHandlerT RESTng RESTngResp+showingResource res = okCxML $ showHtml res --without annotations+++listingResource :: CRUDable a => Proxy a -> [(String,String)] -> [(String,OrderDirection)]+ -> RESTng (GridElement RequestContext)+listingResource pres queryPairs ordBy + = do+ rs <- select (filterFields queryPairs) ordBy pres+ rAndAnnsList <- sequence $ map rAndAnnsPair rs+ return $ (fmap inResourceContext . toContainer . listView ) rAndAnnsList++ where+ filterFields = filter (\(key,_) -> elem key (userFieldsWithKey pres))+ rAndAnnsPair :: AnnotatedResource a => a -> RESTng (a,[(String, GridElement RequestContext)])+ rAndAnnsPair r = do anns <- sequence $ map (listingAnnotation r) annotations+ return (r,anns)+ listingAnnotation :: Resource a => a -> Annotation a -> RESTng (String, GridElement RequestContext)+ listingAnnotation r ann = do cxml <- whenListingElement ann r >>= return . (inElementCtx r)+ return (annotationName ann, whenListingElementLayout ann cxml)+ inElementCtx r = modCx (addResourceIdToCollAddr (show $ key r))+ inResourceContext = modCx (setCollectionFromRootAddr $ resourceType pres)+
+ RESTng/System/Component.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ExistentialQuantification #-}++module RESTng.System.Component where++import Prelude hiding(span, div)+import Data.Maybe (catMaybes)+import Text.CxML+import Text.YuiGrid+import RESTng.RESTngMonad (RESTng)++import RESTng.RqHandlers (RequestContext, addHierarchicalCollToResAddr, setCollectionFromRootAddr)+import RESTng.System.Resource (Resource, Proxy, proxyOf, resourceType, key)+import RESTng.System.Association (AssocOneToMany, findReferringTo, findReferredBy, referringQuery, isAssociatedToType)+import RESTng.System.WebResource (InGridResource, listView, showShortURLHtml)+import RESTng.System.Annotation+++childComponent:: (AssocOneToMany a b, Resource b, InGridResource b) => Proxy b -> Annotation a+childComponent pChild+ = defaultAnnotation {+ annotationName = resourceType pChild,+ whenShowingElement = showChildElements pChild,+ whenEditingElement = showChildElements pChild,+ whenListingElement = showChildElements pChild+ }++showChildElements :: (AssocOneToMany a b, Resource b, InGridResource b) => Proxy b -> a -> RESTng (CxML RequestContext)+showChildElements pChild res+ = do childElems <- findReferringTo res pChild+ return ( div /- [t $ resourceType pChild ++ "s:"] ++++ inChildContext ( (concatCxML . map fromGridNode . listView . withoutAnnotations) childElems)+ )+ where+ inChildContext = modCx (addHierarchicalCollToResAddr (resourceType pChild) restQuery)+ restQuery = referringQuery (proxyOf res) pChild (key res)++ withoutAnnotations :: [a] -> [(a,[b])]+ withoutAnnotations = map (\r->(r,[]))+++referredThroughJoinComponent :: (AssocOneToMany a b, AssocOneToMany c b, Resource b, InGridResource c) =>+ Proxy c -> Proxy b -> Annotation a+referredThroughJoinComponent pReferred pJoin+ = defaultAnnotation {+ annotationName = resourceType pReferred,+ whenShowingElement = showReferredThroughJoinElements pReferred pJoin,+ whenEditingElement = showReferredThroughJoinElements pReferred pJoin,+ whenListingElement = showReferredThroughJoinElements pReferred pJoin+ }++showReferredThroughJoinElements :: (AssocOneToMany a b, AssocOneToMany c b, Resource b, InGridResource c) =>+ Proxy c -> Proxy b -> a -> RESTng (CxML RequestContext)+showReferredThroughJoinElements pReferred pJoin res+ = do joinElems <- findReferringTo res pJoin+ referredElems <- (sequence $ map (`findReferredBy` pReferred) joinElems) >>= return . catMaybes+ return ( span /- [t $ resourceType pReferred ++ "s:"] ++++ inReferredContext ((concatCxML . map fromGridNode . listView . withoutAnnotations ) referredElems)+ )+ where+ inReferredContext = modCx (setCollectionFromRootAddr $ resourceType pReferred)++ withoutAnnotations :: [a] -> [(a,[b])]+ withoutAnnotations = map (\r->(r,[]))++--FIXME: remove duplicates with nub? would add an Eq contraint over c+++++parentComponent:: (AssocOneToMany a b, InGridResource a) => Proxy a -> Annotation b+parentComponent pParent+ = setInFstSibling $ defaultAnnotation {+ annotationName = resourceType pParent,+ whenShowingElement = showParent pParent,+ whenEditingElement = showParent pParent,+ whenListingElement = showParent pParent+ }++showParent :: (AssocOneToMany a b, InGridResource a) => Proxy a -> b -> RESTng (CxML RequestContext)+showParent pParent res+ = do maybeParent <- findReferredBy res pParent+ return ( (span /- [t $ resourceType pParent ++ ":"]) ++++ (span /- [parentCxML maybeParent]) +++ br+ )+ where+ parentCxML maybeParent =+ case maybeParent of+ Nothing -> t ""+ Just parentRes -> showShortURLHtml parentRes+++data ParentBox b = forall a . (AssocOneToMany a b, InGridResource a) => ParentBox (Proxy a)++parentListComponent:: [ParentBox b] -> Annotation b+parentListComponent pParentList+ = setInFstSibling $ defaultAnnotation {+ annotationName = "Parent",+ whenShowingElement = showParentFromList pParentList,+ whenEditingElement = showParentFromList pParentList,+ whenListingElement = showParentFromList pParentList+ }++showParentFromList :: [ParentBox b] -> b -> RESTng (CxML RequestContext)+showParentFromList [] res = return $ t ""+showParentFromList (ParentBox pParent: pParentList) res+ = if res `isAssociatedToType` pParent+ then showParent pParent res+ else showParentFromList pParentList res
+ RESTng/System/FormFields.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +module RESTng.System.FormFields where++import RESTng.System.Proxy+import Control.Monad.Reader+import Control.Monad.Writer+++type ValidationError = String++class (Show a, Read a) => Field a where++ showField :: a -> String+ showField = show++ readField :: String -> Maybe a+ readField s = case reads s of + [(x,"")] -> Just x+ _ -> Nothing++ defaultValue :: a++ defaultValidationError :: Proxy a -> String -> ValidationError+ defaultValidationError _ name = "The attribute '" ++ name ++ "' is invalid"++instance Field [Char] where + showField = id+ readField = Just+ defaultValue = ""++instance Field Bool where + defaultValue = True+ defaultValidationError _ name = "The attribute '" ++ name ++ "' must be False or True"+++instance Field Integer where + defaultValue = 0+ defaultValidationError _ name = "The attribute '" ++ name ++ "' must be an integer"++instance Field Int where + defaultValue = 0+ defaultValidationError _ name = "The attribute '" ++ name ++ "' must be an integer"++instance Field Float where + defaultValue = 0+ defaultValidationError _ name = "The attribute '" ++ name ++ "' must be a number"+++++-----------------------------+----- Validator Monad -------+-----------------------------++type AssocList = [(String,String)]++newtype AssocListValidator a = ALV { runALV :: ReaderT AssocList (Writer [(String,ValidationError)]) a }+ deriving (Monad, MonadReader AssocList, MonadWriter [(String,ValidationError)])++-- to run the monad+runParserAndValidator :: AssocListValidator a -> AssocList -> Either [(String,ValidationError)] a+runParserAndValidator m fields = + case (runWriter . ($ fields) . runReaderT . runALV) m of + (x, []) -> Right x+ (_, msgs) -> Left msgs+++parseAndValidateValue :: String -> (String->Maybe a) -> (a->Bool) -> a -> ValidationError -> AssocListValidator a+parseAndValidateValue name parser validation returnIfInvalid msgIfInvalid = + do env <- ask+ case lookup name env >>= parser of+ Nothing -> catchAndLog+ Just val -> if validation val+ then return val+ else catchAndLog+ where+ catchAndLog = tell [(name,msgIfInvalid)] >> return returnIfInvalid++++-------------------------------------------------+-- Field validation functions (not primitive) ---+-------------------------------------------------++parseAndValidateField :: Field a => String -> (a->Bool) -> ValidationError -> AssocListValidator a+parseAndValidateField name validation msgIfInvalid = + parseAndValidateValue name readField validation defaultValue msgIfInvalid+++parseField :: Field a => String -> AssocListValidator a+--parseField name = parseAndValidateField name (\_->True) (defaultValidationError (proxyOf undefined))+-- had to comment last line and make a more complex definition to solve ambiguity type problem on the defaultValidationError argument+parseField name = let + m = parseAndValidateField name (\_->True) (defaultValidationError' m (proxyOf undefined) name)+ defaultValidationError' :: Field a => m a -> Proxy a -> String -> ValidationError+ defaultValidationError' _ = defaultValidationError+ in m+++parseNotEmpty :: String -> AssocListValidator String+parseNotEmpty name = parseAndValidateField name (not . null) ("The attribute '" ++ name ++ "' can not be empty")+
+ RESTng/System/ORM.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-}+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}++module RESTng.System.ORM++where++import Data.Maybe+import Data.List (intercalate)+import Database.HDBC+import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL)+import Control.Monad.Error+import Data.Typeable (TypeRep)+import Data.Generics++import RESTng.Utils (safeHead, low)+import RESTng.System.Resource+import RESTng.System.RelationalResource+import RESTng.System.ORMTypesConv+++-------------------------------------------+------ Table type -----------------------+-------------------------------------------++type AttrDesc = (String, -- name+ SqlColumnDesc, -- type+ Maybe String) -- default value++type TableDesc = (String, -- name+ [AttrDesc])++-------------------------------------------+------ Error type and Error Monads --------+-------------------------------------------++data OrmError = DbCmdError String -- the hdbc command failed. Track sql command and error message+ | NoSqlColumnDescr [TypeRep] -- no description associated for these types.+-- | NeedDefaultValuesFor [String] -- list of not null attributes+ | OtherError String+ deriving Show++instance Error OrmError where+ noMsg = OtherError "ORM error"+ strMsg s = OtherError s++type OrmMonad = Either OrmError++type OrmMonadIO = ErrorT OrmError IO+runOrmMonadIO :: OrmMonadIO a -> IO (Either OrmError a)+runOrmMonadIO = runErrorT++ormMonad :: OrmMonad a -> OrmMonadIO a+ormMonad o = ErrorT $ return o++liftSqlError :: IO a -> OrmMonadIO a+liftSqlError action = ErrorT $ catchSql (fmap Right action) (return . Left . DbCmdError . show)++++---------------------------------------------------------+------ Class of resources whose tables can be created --+---------------------------------------------------------++class RelationalResource a => CanCreateSchemaForResource a where+ userFieldsReps :: Proxy a -> [TypeRep]+ userFieldsDefaultValues :: Proxy a -> [Maybe String] -- default value sql expression+++userFieldsColDesc :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> Either OrmError [SqlColumnDesc]+userFieldsColDesc pr assoc = case partitionEithers translationList of+ ([], coldescs) -> Right coldescs+ (typeReps, _) -> Left $ NoSqlColumnDescr typeReps+ where+ translationList :: [Either TypeRep SqlColumnDesc]+ translationList = map worker $ zip usrfields (map (`typeRepToSqlColumnDesc` assoc) usrfields)+ usrfields = userFieldsReps pr+ worker (typeRep, Nothing) = Left typeRep+ worker (_, Just coldesc) = Right coldesc++ partitionEithers l = (lefts l, rights l)+ lefts = catMaybes . map (either Just (\_->Nothing))+ rights = catMaybes . map (either (\_->Nothing) Just)+++usrFieldsSqlAttrs :: CanCreateSchemaForResource a =>+ Proxy a -> TypesAssoc -> OrmMonad [AttrDesc]+usrFieldsSqlAttrs pr assoc = do uColDescs <- userFieldsColDesc pr assoc+ return $ zip3 (map low $ userFields pr) uColDescs (userFieldsDefaultValues pr)+++systemFieldsSqlAttrs :: CanCreateSchemaForResource a => Proxy a -> [AttrDesc]+systemFieldsSqlAttrs pr + = ("id",(SqlBigIntT, False), Nothing) : maybeOwnerAttr+ where+ maybeOwnerAttr = if ownable pr+ then [ (ownerIdName pr, (SqlBigIntT, False), Nothing) ]+ else []+++++--------------------------------------------------------------------------------------+-- Highest level functions for creating resources for an heterogeneous lists of res --+--------------------------------------------------------------------------------------++data CanCreateSchemaProxyBox = forall a. (CanCreateSchemaForResource a) => CrBox (Proxy a)++ensureResourceTables :: [CanCreateSchemaProxyBox] -> TypesAssoc -> String -> IO ()+ensureResourceTables boxList assoc connStr+ = handleSqlError $+ do conn <- connectPostgreSQL connStr+ ts <- fmap (map low) $ getTables conn+ sequence_ $ map (\box -> ensureBoxedResourceTable box assoc ts conn) boxList+ disconnect conn+++ensureBoxedResourceTable :: CanCreateSchemaProxyBox -> TypesAssoc -> [String] -> Connection -> IO Bool+ensureBoxedResourceTable (CrBox pr) = ensureResourceTable pr+++ensureResourceTable :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> [String] -> Connection -> IO Bool+ensureResourceTable pr assoc tablesInDB conn+ = do let tname = low (tableName pr)+ putStrLn ("Ensuring table: " ++ tname)+ eitherResult <- runOrmMonadIO $ ensureResourceTable' pr assoc tablesInDB conn+ case eitherResult of+ Left e -> do rollback conn + putStrLn (tname ++ " FAILURE: " ++ show e) >> putStrLn "" >> putStrLn ""+ return True++ Right _ -> do commit conn+ putStrLn (tname ++ " OK") >> putStrLn "" >> putStrLn ""+ return False+++ensureResourceTable' :: CanCreateSchemaForResource a => Proxy a -> TypesAssoc -> [String] -> Connection -> OrmMonadIO ()+ensureResourceTable' pr assoc tablesInDB conn+ = do ufieldsAttrs <- ormMonad $ usrFieldsSqlAttrs pr assoc+ let tname = low (tableName pr)+ maybeAttrs <- if tname `elem` tablesInDB+ then fmap Just (describeTableInDB tname conn)+ else return Nothing++ ensureTable (tname, systemFieldsSqlAttrs pr ++ ufieldsAttrs) maybeAttrs conn++describeTableInDB :: String -> Connection -> OrmMonadIO [AttrDesc]+describeTableInDB t conn+ = do attrDescs <- liftSqlError (describeTable conn t)+ return $ map makeAttr attrDescs+ where+ makeAttr :: (String, SqlColDesc) -> AttrDesc+ makeAttr (name, colDesc) = (low name, hdbcToSqlColumnDesc colDesc, Nothing)+++ensureTable :: TableDesc -> Maybe [AttrDesc] -> Connection -> OrmMonadIO ()+ensureTable t Nothing conn = createTable t conn+ensureTable (t, requiredAttrs) (Just attrsInDB) conn+ = sequence_ $ map ensureAttr' requiredAttrs+ where+ ensureAttr' reqAttr = ensureAttr t reqAttr attrsInDB conn++ensureAttr :: String -> AttrDesc -> [AttrDesc] -> Connection -> OrmMonadIO ()+ensureAttr t (colName, colDesc, defValue) attrsInDB conn+ = case maybeSameInDB of+ Nothing -> addColumn t (colName, colDesc, defValue) conn+ (Just (_, cDesc, defVal)) -> ensureAttrTypeAndDef t colName (colDesc, defValue) (cDesc, defVal) conn+ where+ maybeSameInDB = safeHead $ filter (\(n,_,_)-> n==colName) attrsInDB+++ensureAttrTypeAndDef :: String -> String -> (SqlColumnDesc, Maybe String) -> (SqlColumnDesc, Maybe String) + -> Connection -> OrmMonadIO ()++ensureAttrTypeAndDef t colName ((reqColType,reqColNullable), reqDefValue) ((colTypeInDB,colNullableInDB), defValueInDB) conn+ = if reqColType /= colTypeInDB+ then do -- the attribute in DB has a different type, then rename it and create a new one+ renameColumnInteractive t colName conn+ addColumn t (colName, (reqColType,reqColNullable), reqDefValue) conn+ else do+ if reqColNullable /= colNullableInDB+ then setNullable t colName reqColNullable conn+ else return ()++ ensureAttrDef t colName reqDefValue defValueInDB conn+++ensureAttrDef :: String -> String -> Maybe String -> Maybe String -> Connection -> OrmMonadIO ()+ensureAttrDef t colname reqDefValue _ conn = setDefault t colname reqDefValue conn+-- FIXME: get default value in DB and compare with required one to do or avoid the setting/dropping+-- getting the default in DB must be done in other function. Since it is not being done yet+-- we ignore the parameter here (we macht it with _ )++++-----------------------------------------------------------+-- Not so high level functions acting on the db -----------+-----------------------------------------------------------++createTable :: TableDesc -> Connection -> OrmMonadIO ()+createTable (t, attrs) conn + = do+ liftSqlError $ do putStrLn " A table will be created"+ putStrLn (" Query: \"" ++ createSql ++ "\"")+ putStrLn ""+ run conn createSql []++ liftSqlError $ do putStrLn " The primary key will be set"+ putStrLn (" Query: \"" ++ addPKSql ++ "\"")+ putStrLn ""+ run conn addPKSql []+ return ()+ where+ createSql = createTableSql t attrs+ addPKSql = addPrimaryKeySql t++++addColumn :: String -> AttrDesc -> Connection -> OrmMonadIO ()+addColumn t (colName, coldesc, columnDefVal) conn + = do+ liftSqlError $ do putStrLn " A column will be added"+ putStrLn (" Query: \"" ++ addColSql ++ "\"")+ putStrLn ""+ run conn addColSql []+ return ()+ where+ addColSql = addColumnSql t colName coldesc columnDefVal+--FIXME: allow setting default just for a while if necessary for this step.+--preguntar cuantas filas hay. SELECT COUNT (*) FROM table++renameColumnInteractive :: String -> String -> Connection -> OrmMonadIO ()+renameColumnInteractive t colName conn+ = do + ds <- liftSqlError $ describeTable conn t+ renameColumnInteractive' t colName (colName ++ "_old") (map (low . fst) ds) conn+ +renameColumnInteractive' :: String -> String -> String -> [String] -> Connection -> OrmMonadIO ()+renameColumnInteractive' t colName newName existingColNames conn+ = if newName `elem` existingColNames+ then do nameFromUsr <- liftIO (showErrorMsg >> askNewName)+ if null nameFromUsr + then throwError (OtherError $ "Field already in use: " ++ newName)+ else renameColumnInteractive' t colName nameFromUsr existingColNames conn+ else renameColumn t colName newName conn++ where+ showErrorMsg :: IO ()+ showErrorMsg = do putStrLn ("Need to rename column " ++ colName ++ + " but cannot since the new name is already in use (" ++ newName ++ ")")+ askNewName :: IO String+ askNewName = do putStrLn "Please enter a new name or an empty string to abort." >> putStr "> "+ getLine+++renameColumn :: String -> String -> String -> Connection -> OrmMonadIO ()+renameColumn t colName newName conn+ = do+ liftSqlError $ do putStrLn " A column will be renamed"+ putStrLn (" Query: \"" ++ renColSql ++ "\"")+ run conn renColSql []+ liftIO $ putStrLn ""+ where+ renColSql = renameColumnSql t colName newName+++setDefault :: String -> String -> Maybe String -> Connection -> OrmMonadIO ()+setDefault _ "id" _ _ = return ()+setDefault t colName columnDefVal conn+ = do+ liftSqlError $ do putStrLn " A column will be modified for setting or dropping the default value"+ putStrLn (" Query: \"" ++ setDefSql ++ "\"")+ putStrLn ""+ run conn setDefSql []+ return ()+ where+ setDefSql = setDefaultSql t colName columnDefVal++setNullable :: String -> String -> Bool -> Connection -> OrmMonadIO ()+setNullable t colName colNullable conn+ = do+ liftSqlError $ do putStrLn " A column will be modified for setting or dropping NOT NULL"+ putStrLn (" Query: \"" ++ setNullSql ++ "\"")+ putStrLn ""+ run conn setNullSql []+ return ()+ where+ setNullSql = setNullableSql t colName colNullable+--FIXME: allow setting default just for a while if necessary for this step.+-- preguntar cuantos hay que tienen null++------------------------------------+-- Pretty printing SQL functions ---+------------------------------------++createTableSql :: String -> [(String,SqlColumnDesc,Maybe String)] -> String+createTableSql t attrs+ = concat ["CREATE TABLE ", t, " (",+ intercalate ", " (map renderAttr attrs), ")" ]+ where+ renderAttr (name, coldesc, columnDefVal) = sqlAttributeDescription name coldesc columnDefVal+++addPrimaryKeySql :: String -> String+addPrimaryKeySql t = "ALTER TABLE " ++ t ++ " ADD CONSTRAINT " ++ keyname ++ " PRIMARY KEY (id);"+ where keyname = t ++ "_pkey"++addColumnSql :: String -> String -> SqlColumnDesc -> Maybe String -> String+addColumnSql t colName coldesc columnDefVal + = concat ["ALTER TABLE ", t, + " ADD COLUMN ", sqlAttributeDescription colName coldesc columnDefVal,+ ";" ]++renameColumnSql :: String -> String -> String -> String+renameColumnSql t oldColName newColName+ = concat ["ALTER TABLE ", t, + " RENAME ", oldColName, " TO ", newColName, ";" ]++setDefaultSql :: String -> String -> Maybe String -> String+setDefaultSql t colName columnDefVal + = concat ["ALTER TABLE ", t, + " ALTER COLUMN ", colName,+ setOrDrop columnDefVal,+ ";" ]+ where+ setOrDrop Nothing = " DROP DEFAULT"+ setOrDrop (Just defVal) = " SET DEFAULT " ++ defVal++setNullableSql :: String -> String -> Bool -> String+setNullableSql t colName nullable + = concat ["ALTER TABLE ", t, + " ALTER COLUMN ", colName,+ (if nullable then " DROP" else " SET"), " NOT NULL",+ ";" ]++sqlAttributeDescription :: String -> SqlColumnDesc -> Maybe String -> String+sqlAttributeDescription "id" _ _ = "id serial NOT NULL"+sqlAttributeDescription colName (columnType, columnNullable) columnDefVal+ = concat [colName, + " ", renderSqlTypeId columnType,+ renderNullable columnNullable, + fromMaybe "" (fmap (" DEFAULT " ++) columnDefVal)+ ]+ where+ renderNullable True = ""+ renderNullable False = " NOT NULL"++++-------------------------------------------------+-- Automatic instance from type introspection ---+-------------------------------------------------+instance (Data a, RelationalResource a) => CanCreateSchemaForResource a where+-- userFieldsReps :: Proxy a -> [TypeRep]+ userFieldsReps pr = dropSystemReps (gmapQ typeOf (buildDummy pr))+ where+ buildDummy :: Data a => Proxy a -> a+ buildDummy pr = fromConstr $ indexConstr (dataTypeOf (fromProxy pr)) 1+ fromProxy :: Proxy a -> a+ fromProxy _ = undefined++ dropSystemReps :: [TypeRep] -> [TypeRep]+ dropSystemReps = if ownable pr + then drop 2+ else drop 1+-- FIXME: a different convention is used here. Here we consider that the key is the first one and the owner in case it exists, it is the snd one. In the rest of the framework we did not make assumption on the position, just on the names of the system fields.++-- userFieldsDefaultValues :: Proxy a -> [Maybe String] -- default value sql expression+ userFieldsDefaultValues pr = repeat Nothing+
+ RESTng/System/ORMTypesConv.hs view
@@ -0,0 +1,108 @@+module RESTng.System.ORMTypesConv++where++import Database.HDBC+import Data.Typeable+import System.Time (ClockTime, TimeDiff)++import RESTng.Resources.User (UserRole)+++type SqlColumnDesc = (SqlTypeId, -- HDBC's data type (extracted from a Database.HDBC.SqlColDesc)+ Bool) -- nullable? (extracted from a Database.HDBC.SqlColDesc)++type TypesAssoc = [(TypeRep, SqlColumnDesc)] -- this list is an n x n mapping used for translation, + -- but when looking up the translation of either side, just the first element of + -- the other side will be retrieved++typeRepToSqlColumnDesc :: TypeRep -> TypesAssoc -> Maybe SqlColumnDesc+typeRepToSqlColumnDesc = lookup+++hdbcToSqlColumnDesc :: SqlColDesc -> SqlColumnDesc+hdbcToSqlColumnDesc c = case colNullable c of+ Nothing -> error ("don't know if the column is nullable: " ++ show c)+ Just b -> (colType c, b)++typesAssoc :: [(TypeRep, SqlColumnDesc)]+typesAssoc = map nullableTypeAssoc basicTypesAssocs ++ + map notNullableTypeAssoc basicTypesAssocs+ where+ notNullableTypeAssoc (trep, sqltype) = (trep, (sqltype, False))+ nullableTypeAssoc (trep, sqltype) = (mkTyConApp typeConOfMaybe [trep], (sqltype, True))+++basicTypesAssocs :: [(TypeRep, SqlTypeId)]+basicTypesAssocs =+ [+ (stringTR, SqlVarCharT),+ (integerTR, SqlBigIntT),+ (boolTR, SqlBitT),+ (clockTimeTR, SqlTimestampT),+ (userRolesTR, SqlVarCharT),++ (stringTR, SqlCharT),+ (stringTR, SqlVarCharT),+ (stringTR, SqlLongVarCharT),+ (stringTR, SqlWCharT),+ (stringTR, SqlWVarCharT),+ (stringTR, SqlWLongVarCharT),+ (rationalTR, SqlDecimalT),+ (rationalTR, SqlNumericT),+-- ("Int32", SqlSmallIntT),+-- ("Int32", SqlIntegerT),+ (rationalTR, SqlRealT),+ (floatTR, SqlFloatT),+ (doubleTR, SqlDoubleT),+ (boolTR, SqlBitT),+-- ("Int32", SqlTinyIntT),+-- ("Int64", SqlBigIntT),+-- ("", SqlBinaryT),+-- ("", SqlVarBinaryT),+-- ("", SqlLongVarBinaryT),+ (clockTimeTR, SqlDateT),+ (clockTimeTR, SqlTimeT),+ (clockTimeTR, SqlTimestampT),+ (clockTimeTR, SqlUTCDateTimeT),+ (timeDiffTR, SqlUTCTimeT)+-- ("", SqlIntervalT SqlInterval),+-- ("", SqlGUIDT),+-- ("", SqlUnknownT String),+ ]++renderSqlTypeId :: SqlTypeId -> String+renderSqlTypeId SqlVarCharT = "text"+renderSqlTypeId SqlBigIntT = "int4"+renderSqlTypeId SqlBitT = "bool"+renderSqlTypeId SqlTimestampT = "timestamptz"+--renderSqlTypeId SqlDecimalT = "???"+renderSqlTypeId SqlFloatT = "float4"+renderSqlTypeId SqlDoubleT = "float8"+--renderSqlTypeId SqlUTCTimeT = "???"+++-- some TypeRep s values+ctTc :: TyCon+ctTc = mkTyCon "System.Time.ClockTime"+instance Typeable ClockTime where typeOf _ = mkTyConApp ctTc []++ctTd :: TyCon+ctTd = mkTyCon "System.Time.TimeDiff"+instance Typeable TimeDiff where typeOf _ = mkTyConApp ctTd []++stringTR = typeOf (undefined :: String)+--int32TR = typeOf (undefined :: Int32)+--int64TR = typeOf (undefined :: Int64)+intTR = typeOf (undefined :: Int)+integerTR = typeOf (undefined :: Integer)+rationalTR = typeOf (undefined :: Rational)+floatTR = typeOf (undefined :: Float)+doubleTR = typeOf (undefined :: Double)+boolTR = typeOf (undefined :: Bool)+clockTimeTR = typeOf (undefined :: ClockTime)+timeDiffTR = typeOf (undefined :: TimeDiff)+userRolesTR = typeOf (undefined :: [UserRole])++typeConOfMaybe = (typeRepTyCon . typeOf) (Just ())+
+ RESTng/System/Permission.hs view
@@ -0,0 +1,65 @@+module RESTng.System.Permission where++import Control.Monad.Trans (lift)+import RESTng.RESTngMonad (RESTng, getAuthUser)++import RESTng.RqHandlers (RequestContext, RqHandlerT, ifReq, ifGet, anyOf, okNonCxMLStrRsp, RESTngResp)+import RESTng.System.Resource (Proxy, proxyOf, Resource, ownerId, setOwnerId, ownable)+import RESTng.System.Authentication (withAuthentication)+import RESTng.Resources.User (User, UserRole, UserRole(Admin), user_id, roles)+++type Permission a = a -> Maybe User -> Bool++withAnyRoleCan, ownerOrWithAnyRoleCan :: Resource a => [UserRole] -> Permission a++withAnyRoleCan rs _ (Just uid) = any (\role -> elem role (roles uid)) rs+withAnyRoleCan _ _ _ = False++ownerOrWithAnyRoleCan rs a u = onlyOwnerCan a u || withAnyRoleCan rs a u+++onlyAdminCan, onlyOwnerCan, ownerOrAdminCan, authdCan, everybodyCan, nobodyCan :: Resource a => Permission a++onlyAdminCan a (Just u) = elem Admin (roles u)+onlyAdminCan _ _ = False++onlyOwnerCan a (Just u) = ownable (proxyOf a) && (ownerId a == user_id u)+onlyOwnerCan _ _ = False++ownerOrAdminCan a u = onlyOwnerCan a u || onlyAdminCan a u++authdCan _ (Just uid) = True+authdCan _ _ = False++everybodyCan _ _ = True++nobodyCan _ _ = False+++-- Permission combinators+allPerm :: [Permission a] -> Permission a+allPerm ps a u = all (\p' -> p' a u) ps++anyPerm :: [Permission a] -> Permission a+anyPerm ps a u = any (\p' -> p' a u) ps++-- testing permissions++allowedForUser :: Resource a => a -> Permission a -> RESTng Bool+allowedForUser a p = fmap (p a) getAuthUser++checkPermissions :: Resource a => [Permission a] -> a -> RqHandlerT RESTng RESTngResp -> RqHandlerT RESTng RESTngResp+checkPermissions ps a han = do u <- lift $ getAuthUser+ if all (\p -> p a u) ps+ then han+ else (anyOf [ifGet $ withAuthentication forbidden, forbidden] )++-- the evaluation of (withAuthentication forbidden) when checking the permissions has failed is tricky. +-- If the user was authenticated, then the permissions are not enought so the result is forbidden+-- If the user was not authenticated, after requiring authentication the request will be retried+-- Retry in withAuthentication is not implemented for post request for the moment+++forbidden :: Monad m => RqHandlerT m RESTngResp+forbidden = return $ okNonCxMLStrRsp "Operation forbidden"
+ RESTng/System/PersistableResource.hs view
@@ -0,0 +1,70 @@+module RESTng.System.PersistableResource where++import RESTng.Database.SQL (OrderDirection)+import RESTng.RESTngMonad (RESTng, liftHDBC_0)+import RESTng.System.Resource (Proxy)+import RESTng.System.RelationalResource+import RESTng.Utils(safeHead)++class PersistableResource a where++ insert :: a -> RESTng a+ update :: a -> RESTng ()+ delete :: Integer -> Proxy a -> RESTng ()+ select :: [(String,String)] -> -- restrictions+ [(String,OrderDirection)] -> -- order by+ Proxy a -> RESTng [a]+ find :: Integer -> Proxy a -> RESTng (Maybe a)++ persistableFunctions :: (+ a -> RESTng a, --insert+ a -> RESTng (), --update+ Integer -> Proxy a -> RESTng (), --delete+ [(String,String)] -> [(String,OrderDirection)] -> + Proxy a -> RESTng [a], --select+ Integer -> Proxy a -> RESTng (Maybe a) --find+ )++ persistableFunctions = (insert, update, delete, select, find)+ insert = ins where (ins,upd,del,sel,fin) = persistableFunctions+ update = upd where (ins,upd,del,sel,fin) = persistableFunctions+ delete = del where (ins,upd,del,sel,fin) = persistableFunctions+ select = sel where (ins,upd,del,sel,fin) = persistableFunctions+ find = fin where (ins,upd,del,sel,fin) = persistableFunctions+++persistableFromRelational :: RelationalResource a => + (+ a -> RESTng a, --insert+ a -> RESTng (), --update+ Integer -> Proxy a -> RESTng (), --delete+ [(String,String)] -> [(String,OrderDirection)] -> + Proxy a -> RESTng [a], --select+ Integer -> Proxy a -> RESTng (Maybe a) --find+ )+++persistableFromRelational = (r_insert, r_update, r_delete, r_select, r_find)+++r_insert :: RelationalResource a => a -> RESTng a+r_insert a = liftHDBC_0 (dbInsert a)++r_update :: RelationalResource a => a -> RESTng ()+r_update a = liftHDBC_0 (dbUpdate a) >> return ()++r_delete :: RelationalResource a => Integer -> Proxy a -> RESTng ()+r_delete k pa = liftHDBC_0 (dbDelete k pa) >> return ()++r_select :: RelationalResource a => [(String,String)] -> [(String,OrderDirection)] -> Proxy a -> RESTng [a]+r_select filt ordBy pa = liftHDBC_0 (dbSelect filt ordBy pa)++r_find :: RelationalResource a => Integer -> Proxy a -> RESTng (Maybe a)+r_find k pa = liftHDBC_0 (dbSelectOne k pa)+++----------------------------------------------------------++select01 :: PersistableResource a => [(String,String)] -> Proxy a -> RESTng (Maybe a)+select01 crit p = select crit [] p >>= (return . safeHead)+
+ RESTng/System/Proxy.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE EmptyDataDecls #-}+module RESTng.System.Proxy (+ Proxy, proxyOf+ ) where++data Proxy a+proxyOf :: a -> Proxy a+proxyOf = undefined++annotateTypeWithProxy :: Proxy a -> m a -> m a+annotateTypeWithProxy _ ma = ma+++
+ RESTng/System/RelationalResource.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}++module RESTng.System.RelationalResource where++import Database.HDBC.PostgreSQL (Connection)+import Database.HDBC (SqlValue, toSql)+import Data.Maybe (fromMaybe)+import Control.Monad (liftM2)++import RESTng.Database.SQL+import RESTng.Database.Record+import RESTng.System.Resource+import RESTng.Utils(safeHead)++class Resource a => RelationalResource a where --requires FlexibleInstances+ userFieldsToSql :: a -> [SqlValue]+ sqlUserFieldsParser :: SystemFields -> SqlValueParser a++ tableName :: Proxy a -> String+ tableName = resourceType++ sqlInsert :: a -> SqlCommand+ sqlInsert = sqlInsertDefault+ sqlUpdate :: a -> SqlCommand+ sqlUpdate = sqlUpdateDefault+ sqlDelete :: Integer -> Proxy a -> SqlCommand+ sqlDelete = sqlDeleteDefault+ sqlSelect :: [(String,String)] -> [(String,OrderDirection)] -> Proxy a -> SqlCommand+ sqlSelect = sqlSelectDefault+ sqlSelectOne :: Integer -> Proxy a -> SqlCommand+ sqlSelectOne = sqlSelectOneDefault+++class RelationalResource a => RelationalOneToMany a b where --requires MultiParamTypeClasses+ fkName :: Proxy a -> Proxy b -> String -- both a and b might be proxies+ fkName a _ = tableName a ++ "_id"+ fkValue :: Proxy a -> b -> Integer++ sqlSelectByFK :: RelationalResource b => a -> Proxy b -> SqlCommand -- this decl requires FlexibleContexts+ sqlSelectByFK = sqlSelectByFKDefault+++keySql :: RelationalResource a => a -> SqlValue+keySql = toSql . key++nonKeyFieldsToSql :: RelationalResource a => a -> [SqlValue]+nonKeyFieldsToSql r = if ownable (proxyOf r)+ then toSql (ownerId r): userFieldsToSql r+ else userFieldsToSql r++sqlSystemFieldsParser :: Resource a => Proxy a -> SqlValueParser SystemFields+sqlSystemFieldsParser pr = liftM2 (,) sqlFieldParser ownerParser+ where+ ownerParser = if ownable pr+ then sqlFieldParser >>= return . Just+ else return Nothing++sqlResourceParser :: RelationalResource a => Proxy a -> SqlValueParser a+sqlResourceParser pr = sqlSystemFieldsParser pr >>= sqlUserFieldsParser+++dataForCommands :: RelationalResource a => a -> (String, String, SqlValue, [String], [SqlValue])+dataForCommands a = (tableName pa, keyName pa, keySql a, nonKeyFields pa, nonKeyFieldsToSql a)+ where+ pa = proxyOf a++typeForCommands :: RelationalResource a => Proxy a -> (String, String, [String])+typeForCommands pa = (tableName pa, keyName pa, nonKeyFields pa)+++sqlInsertDefault :: RelationalResource a => a -> SqlCommand+sqlInsertDefault = sqlInsert' . dataForCommands+sqlInsert' (tableName, keyName, _, fields, values)+ = setReturning keyName $ insertCmd tableName (zip fields values)++sqlUpdateDefault :: RelationalResource a => a -> SqlCommand+sqlUpdateDefault r = sqlUpdate' r (dataForCommands r)+sqlUpdate' r (tableName, keyName, keyValue, _, _)+ = restrictAttr keyName keyValue $+ updateCmd tableName (zip (userFields $ proxyOf r) (userFieldsToSql r) )++sqlDeleteDefault :: RelationalResource a => Integer -> Proxy a -> SqlCommand+sqlDeleteDefault k = sqlDelete' k . typeForCommands+sqlDelete' k (tableName, keyName, _)+ = restrictAttr keyName (toSql k) $+ deleteCmd tableName++sqlSelectDefault :: RelationalResource a => [(String,String)] -> [(String,OrderDirection)]+ -> Proxy a -> SqlCommand+sqlSelectDefault filt ordBy = sqlSelect' filt ordBy . typeForCommands+sqlSelect' filt ordBy (tableName, keyName, fields)+ = setOrderList ordBy $+ projectAttrs (map ((tableName++".")++)(keyName:fields)) $+ restrictAttrs filt' $+ selectCmd [tableName]+ where filt' = [(attr,toSql valStr) | (attr,valStr) <- filt ]++sqlSelectOneDefault :: RelationalResource a => Integer -> Proxy a -> SqlCommand+sqlSelectOneDefault k = sqlSelectOne' k . typeForCommands+sqlSelectOne' k (tableName, keyName, fields)+ = projectAttrs (keyName:fields) $+ restrictAttr keyName (toSql k) $+ selectCmd [tableName]+++-- | Generates the sql string to get objects of type "b" belonging to objects of type "a".+-- The fst parameter is used to infer the name of FK name in type "b" (type of snd param)+-- and also to get the id value to be used in the search of objects of type "b"+-- TODO : Check that the label name inferred exists. Check that key types match+sqlSelectByFKDefault :: (RelationalOneToMany a b, RelationalResource b) => a -> Proxy b -> SqlCommand+sqlSelectByFKDefault a pb = sqlSelectByFK' a (fkName (proxyOf a) pb) $ typeForCommands pb+sqlSelectByFK' a fkName' (tableName, keyName, fields)+ = projectAttrs (keyName:fields) $+ restrictAttr fkName' (akValue) $+ selectCmd [tableName]+ where+ akValue = toSql $ key a++++dbInsert :: RelationalResource a => a -> Connection -> IO a+dbInsert a conn = do maybeResKey <- runTransactionReturningId (sqlInsert a) conn+ return (setKey a (fromMaybe 0 maybeResKey))+-- TODO: actually return a new object with the actual id+++-- | Receives a connection and a record. Tries to update the record (the key is inferred from the record).+-- In case there is an error, it is the IO fail, in case it succeeds, the number of updated records is returned+-- This number should be usually 1.+dbUpdate :: RelationalResource a => a -> Connection -> IO Integer+dbUpdate a = runTransaction (sqlUpdate a)++-- | Receives a connection and a key. Tries to delete a record with the key.+-- In case there is an error, it is the IO fail, in case it succeeds, the number of updated records is returned+-- This number should be usually 1.+dbDelete :: RelationalResource a => Integer -> Proxy a -> Connection -> IO Integer+dbDelete k pa = runTransaction (sqlDelete k pa)+++-- | Receives a connection and a proxy and a list of values to filter. The proxy is used for inferring the type and table.+-- All the records in the table are returned in a list that match the criteria.+-- In case there is an error, it is the IO fail.+dbSelect :: RelationalResource a => [(String,String)] -> [(String,OrderDirection)] -> Proxy a -> Connection -> IO [a]+dbSelect filt ordBy pa = runQueryN sqlRecordParser (sqlSelect filt ordBy pa)+++-- | Receives a connection and a key. Tries to get the record from the db+-- In case there is an error, it is the IO fail.+dbSelectOne :: RelationalResource a => Integer -> Proxy a -> Connection -> IO (Maybe a)+dbSelectOne k pa = runQuery01 sqlRecordParser (sqlSelectOne k pa)+++-- | Receives a connection string and two records. +-- The fst parameter is used to infer the name of the foreign key field and the+-- id value to use for the filter.+-- The snd parameter is used just as a proxy for inferring the type and table.+-- All the records of type "b" belonging to (referring to) the object of type "a"+-- are returned in a list. +-- In case there is an error, it is the IO fail.+dbSelectByFK :: (RelationalOneToMany a b, RelationalResource b) => a -> Proxy b -> Connection -> IO [b]+dbSelectByFK a pb = runQueryN sqlRecordParser (sqlSelectByFK a pb)+++instance RelationalResource a => SqlRecord a where+ sqlRecordParser = sqlResourceParser pr+ where pr = proxyOf undefined+
+ RESTng/System/Resource.hs view
@@ -0,0 +1,43 @@+module RESTng.System.Resource (+ module RESTng.System.Proxy,+ OwnerId, SystemFields,+ Resource,+ resourceType, key, setKey, keyName,+ ownable, ownerId, setOwnerId, ownerIdName,+ userFields,+ nonKeyFields, userFieldsWithKey+ ) where++import RESTng.System.Proxy++type OwnerId = Integer+type SystemFields = (Integer, Maybe OwnerId)+ +class Resource a where+ resourceType :: Proxy a-> String++ key :: a -> Integer+ setKey :: a -> Integer -> a+ keyName :: Proxy a -> String; keyName _ = "id"++ ownable :: Proxy a -> Bool; ownable _ = False+ ownerId :: a -> OwnerId+ setOwnerId :: OwnerId -> a -> a+ ownerIdName :: Proxy a -> String; ownerIdName _ = "owner_id"++ userFields :: Proxy a -> [String]+++------------------------------------+-- Serializing to text. (records) --+------------------------------------+nonKeyFields :: Resource a => Proxy a -> [String]+nonKeyFields pr = if ownable pr+ then ownerIdName pr : userFields pr+ else userFields pr+++userFieldsWithKey :: Resource a => Proxy a -> [String]+userFieldsWithKey r = keyName r : userFields r++
+ RESTng/System/WebResource.hs view
@@ -0,0 +1,246 @@+module RESTng.System.WebResource where++import Prelude hiding(span, div)+import Data.List (groupBy, intercalate)+import Data.Char (isUpper, toUpper)+import Data.Maybe (fromJust)++import Text.CxML+import Text.YuiGrid+import Network.HTTP.RedHandler (RequestContext, completeURL, query, addMethodEditToResAddr,+ addMethodDeleteToResAddr, addResourceIdToCollAddr, addMethodNewToCollAddr)++import RESTng.Utils (mapSnd)+import RESTng.System.FormFields+import RESTng.System.Resource++data FormFieldType = HiddenField | TextField | PasswordField | FileField deriving Eq+data FormFieldSpec = FFS {+ fieldType :: FormFieldType,+ fieldName :: String,+ fieldLabel :: String,+ fieldValue :: String,+ fieldWithError :: Bool+ }++renderFormField :: FormFieldSpec -> CxML a+renderFormField (FFS HiddenField name _ val _) = hidden name val+--renderFormField (FFS TextField name label val ferr) = (span /- [t $ label]) +++ (maybeError ferr (textfield name !("value",val))) +++ br+--renderFormField (FFS FileField name label _ ferr) = (span /- [t $ label]) +++ (maybeError ferr (afile name)) +++ br+renderFormField (FFS TextField name label val ferr) = (span /- [maybeError ferr (t label)]) +++ (textfield name !("value",val)) +++ br+renderFormField (FFS FileField name label _ ferr) = (span /- [maybeError ferr (t label)]) +++ afile name +++ br++--maybeError True _tag = div!("background-color","red")!("display","table")!("padding","2px") /- [_tag]+--maybeError False _tag = _tag+maybeError True t = font!("color","red") /- [t]+maybeError False t = t+++class Resource a => WebResource a where+ userFieldValues :: a -> [String] --does not have the key in the list+ userFieldValuesParser :: SystemFields -> AssocListValidator a++ showHtml :: a -> CxML RequestContext+ showShortHtml :: a -> CxML RequestContext+ listElementHtml :: a -> CxML RequestContext+ formFieldsSpec :: Proxy a -> [(String {-label-}, FormFieldType)]++ showHtml res = withCtx $ showHtml' (reflectResourceData res)+ showShortHtml res = withCtx $ showHtml' (reflectResourceData res)++ listElementHtml res = withCtx $ listElementHtml' resname idVal fields+ where+ fields = reflectResourceData res+ resname = resourceType pres+ idVal = show $ key res+ pres = proxyOf res++ formFieldsSpec pr = zip (map renderFieldName $ userFields pr) (repeat TextField)+++formEditHtml :: WebResource a => a -> CxML RequestContext+formEditHtml res = withCtx $ (\cxt -> buildForm (proxyOf res) cxt fields)+ where+ fields = zip3 ufields uvalues (repeat False)+ (ufields, uvalues) = unzip (reflectResourceData res)++formCreateHtml :: WebResource a => Proxy a -> CxML RequestContext+formCreateHtml pres = withCtx $ (\cxt -> buildForm pres cxt fields)+ where+ fields = zip3 (userFields pres) blankValues (repeat False)+ blankValues = repeat ""++formWithErrorsHtml :: WebResource a => Proxy a -> [(String, String, Bool)] -> CxML RequestContext+formWithErrorsHtml pres fields = withCtx $ (\cxt -> buildForm pres cxt fields)++formAndErrorsCxMLs :: WebResource a => Proxy a -> [(String,String)] -> [(String,ValidationError)] -> (CxML RequestContext, CxML RequestContext)+formAndErrorsCxMLs pr fields valErrs = (formWithErrorsHtml pr (map addErrFlag fields), renderValidationErrs valErrs)+ where+ addErrFlag (name,val) = (name,val, name `elem` attrsWithError)+ attrsWithError = map fst valErrs++renderValidationErrs :: [(String,ValidationError)] -> CxML a+renderValidationErrs valErrs = concatCxML $ map ( (p/-) . (:[]) . t . snd) valErrs++userFieldValuesWithKey :: WebResource a => a -> [String]+userFieldValuesWithKey r = show (key r) : userFieldValues r++reflectResourceData :: WebResource a => a -> [(String, String)]+reflectResourceData a = zip (userFields pa) (userFieldValues a)+ where pa = proxyOf a++reflectResourceDataWithKey :: WebResource a => a -> [(String, String)]+reflectResourceDataWithKey a = zip (userFieldsWithKey pa) (userFieldValuesWithKey a)+ where pa = proxyOf a+++runWebParserAndValidator :: WebResource a => Proxy a -> SystemFields -> AssocList -> Either [(String,ValidationError)] a+runWebParserAndValidator _ = runParserAndValidator . userFieldValuesParser++++showShortURLHtml :: WebResource a => a -> CxML RequestContext+showShortURLHtml res = a!("href", ("/" ++ resname ++ "/" ++ idVal)) /- [showShortHtml res]+ where+ resname = resourceType pres+ idVal = show $ key res+ pres = proxyOf res+++showHtml' :: [(String, String)] -> RequestContext -> CxML a+showHtml' fs rqctx = concatCxML $ renderFields fs+ where+ renderFields :: [(String, String)] -> [CxML b]+ renderFields = concat . (map renderField) . (filter shouldShowField)++ shouldShowField :: (String, String) -> Bool+ shouldShowField (name, _) = (not . elem name . fst . unzip . query) rqctx++ renderField :: (String, String) -> [CxML b]+ renderField (name, val) = [span /- [t $ renderFieldName (name ++ ":")],+ span /- [t val],+ br]++-- | rececives a list of triples of data conforming the resource (or blank data if new) and telling if the data is valid+-- and receives the request context with information to prefill the form (overriding and hiding some data fields). The information to build the actionURL is also in the requestContext.+buildForm :: WebResource a => Proxy a -> RequestContext -> [(String, String, Bool)] -> CxML b+buildForm pr rqctx = buildForm' (completeURL rqctx) . map (hideFieldIfFixed . buildFieldSpec) . zip (formFieldsSpec pr)+ where+ buildFieldSpec ((lbl,fType),(name,val, withErrorFlag)) = FFS fType name lbl val withErrorFlag+ hideFieldIfFixed fieldSpec = case lookup (fieldName fieldSpec) q of+ Nothing -> fieldSpec+ Just val' -> fieldSpec { fieldValue = val', fieldType = HiddenField }+ q = query rqctx+--TODO? a possible improvement is to allow scaffolding some fields, (not all or nothing). This would be done by naming each field specification, so some repetition of names is required. If a field is not named, then the defauld field label and type is used.+++buildForm' :: String -> [FormFieldSpec] -> CxML a+buildForm' actionUrl fss = formTagAndAttrs /- (map renderFormField fss ++ [br, buttonTagAndAttrs])+ where+ formTagAndAttrs = if FileField `elem` (map fieldType fss)+ then formTagAndAttrs'!("enctype", "multipart/form-data")+ else formTagAndAttrs'++ formTagAndAttrs' = form!("method","post")!("action", actionUrl)++ buttonTagAndAttrs = button!("name","action")!("value","submit") /- [t "Submit"]++++listElementHtml' :: String -> String -> [(String, String)] -> RequestContext -> CxML a+listElementHtml' aname idVal fs rqctx =+ tr /- ((renderIdField : map renderField fs)+ ++ [editField, deleteField])+ where + renderField :: (String, String) -> CxML a+ renderField (_, val) = td /- [t val]+ renderIdField = td /- [a!("href", showURL) /- [t idVal] ]++ editField, deleteField :: CxML a+ editField = td /- [ a!("href", editURL) /- [t "edit"] ]+ deleteField = td /- [ a!("href", deleteURL)!("onclick", onclickScript) /- [t "delete"] ]++ showURL = completeURL resAddressCtx+ editURL = completeURL $ addMethodEditToResAddr resAddressCtx+ deleteURL = completeURL $ addMethodDeleteToResAddr resAddressCtx++ onclickScript = "if (confirm('Are you sure?')) { var f = document.createElement('form'); f.style.display = 'none'; this.parentNode.appendChild(f); f.method = 'POST'; f.action = this.href;f.submit(); };return false;"+ resAddressCtx = addResourceIdToCollAddr idVal rqctx+++-- Some utility functions++renderFieldName :: String -> String+renderFieldName = capitalize . unwords . groupBy (\_->not . isUpper)+ where capitalize (x:xs) = toUpper x : xs++++class WebResource a => InGridResource a where+ -- the InGridResource methods allow to specify the layout of the result of the WebResource methods and the+ -- annotations+ showLayout :: Proxy a -> CxML RequestContext -> [(String, GridElement RequestContext)] -> [GridElement RequestContext]+ editLayout :: Proxy a -> CxML RequestContext -> [(String, GridElement RequestContext)] -> [GridElement RequestContext]+ createLayout :: Proxy a -> CxML RequestContext -> [(String, GridElement RequestContext)] -> [GridElement RequestContext]+ listView :: [(a, [(String, GridElement RequestContext)])] -> [GridElement RequestContext]++ showLayout = showLayoutDefault+ editLayout = editLayoutDefault+ createLayout = createLayoutDefault+ listView = listInTableView++showLayoutDefault, editLayoutDefault, createLayoutDefault :: InGridResource a =>+ Proxy a -> CxML b -> [(String, GridElement b)] -> [GridElement b]+showLayoutDefault pres cxml anns = (smallMarginBottomCSS . giveBorderCSS . boxInMain) cxml : map snd anns++editLayoutDefault pres cxml anns = boxInMain cxml : map snd anns+createLayoutDefault pres cxml anns = boxInMain cxml : map snd anns+++-- these are the methods aimed to be used in the crud+showView :: InGridResource a => a -> [(String, GridElement RequestContext)] -> [GridElement RequestContext]+showView res anns = showLayout (proxyOf res) (showHtml res) anns++listInBoxesView :: InGridResource a => [(a, [(String, GridElement RequestContext)])] -> [GridElement RequestContext]+listInBoxesView resAndAnns = listInBoxesLayout resProxy (map (\(res,anns)->(showHtml res, anns)) resAndAnns)+ where+ resProxy = (proxyOf . fst . head) resAndAnns++listInBoxesLayout :: InGridResource a => Proxy a -> [(CxML RequestContext,[(String, GridElement RequestContext)])] -> [GridElement RequestContext]+listInBoxesLayout pres = map (inMain . toContainer . uncurry (showLayout pres))++listInTableView :: InGridResource a => [(a, [(String, GridElement RequestContext)])] -> [GridElement RequestContext]+listInTableView resAndAnns = listInTableLayout resProxy (map (\(res,anns)->(listElementHtml res, anns)) resAndAnns)+ where+ resProxy = (proxyOf . fst . head) resAndAnns++listInTableLayout :: InGridResource a => Proxy a -> [(CxML RequestContext,[(String, GridElement RequestContext)])] -> [GridElement RequestContext]+listInTableLayout pres+ = (:[]) . boxInMain . listInTableHtml pres . map (stripLayoutFromAnns)+ where+ stripLayoutFromAnns :: (CxML RequestContext,[(String, GridElement RequestContext)])+ -> (CxML RequestContext,[(String, CxML RequestContext)])+ stripLayoutFromAnns cxmlAndAnnsList = mapSnd (map (mapSnd fromGridNode)) cxmlAndAnnsList+--TODO: make stripLayout safe?+++listInTableHtml :: Resource a => Proxy a -> [(CxML RequestContext,[(String, CxML RequestContext)])] -> CxML RequestContext+listInTableHtml pres cxmlAndAnnsList = withCtx $ listInTableHtml' pres cxmlAndAnnsList++listInTableHtml' :: Resource a => Proxy a -> [(CxML b,[(String, CxML b)])] -> RequestContext -> CxML b+listInTableHtml' pres htmlAndAnns rqctx+ = concatCxML [table /- rowlist htmlAndAnns,+ a!("href", newURL) /- [t "new"],+ br+ ]+ where+ newURL = completeURL $ addMethodNewToCollAddr rqctx+ rowlist :: [(CxML b,[(String, CxML b)])] -> [CxML b]+ rowlist [] = [tr/-[] ] -- add one row in this case since nested tables without rows are not rendered ok in mozilla.+ rowlist htmlAndAnns = map listElementInTableHtml htmlAndAnns++listElementInTableHtml :: (CxML b,[(String, CxML b)]) -> CxML b+listElementInTableHtml (cxml, anns) = cxml /- (map renderAnnotation anns)+ where+ renderAnnotation (_,ann) = td /- [ann]+
+ RESTng/Utils.hs view
@@ -0,0 +1,30 @@+module RESTng.Utils where++import Data.Char(toLower)++-- map-like functions+mapFst f (x,y) = (f x, y)+mapSnd f (x,y) = (x, f y)++-- string conversion+low = map toLower++-- n tuples+fst3 (x,_,_) = x+snd3 (_,x,_) = x+trd3 (_,_,x) = x++fst4 (x,_,_,_) = x+snd4 (_,x,_,_) = x+trd4 (_,_,x,_) = x+fourth4 (_,_,_,x) = x++-- list processing+lookupByFun :: Eq a => (b->a) -> a -> [b] -> Maybe b+lookupByFun f a [] = Nothing+lookupByFun f a (b:bs) = if (f b == a) then Just b+ else lookupByFun f a bs++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x
+ Setup.lhs view
@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+