yesod-vend (empty) → 0.1
raw patch · 4 files changed
+508/−0 lines, 4 filesdep +basedep +blaze-htmldep +hamletsetup-changed
Dependencies added: base, blaze-html, hamlet, persistent, text, yesod, yesod-platform
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Yesod/VEND.hs +454/−0
- yesod-vend.cabal +22/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Krzysztof Skrzętnicki++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Krzysztof Skrzętnicki nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yesod/VEND.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeFamilies, ExistentialQuantification, DefaultSignatures, QuasiQuotes #-}++-----------------------------------------------------------------------------+-- |+-- Module : Yesod.VEND+-- Copyright : 2012 Krzysztof Skrzętnicki <gtener@gmail.com>+-- License : BSD-style (see the LICENSE file in the distribution)+-- +-- Maintainer : Krzysztof Skrzętnicki <gtener@gmail.com>+-- Stability : experimental+-- Portability : portable+-- +-- This module provides simple typeclass 'CRUD' which implements CRUD (or VEND: View Edit New Delete) functionality for Yesod.+-- +-- There are default implementations that are unfortunately filtered out by Haddock. The implementation uses DefaultSignatures extension to not force a specific implementation on a library user.+-- +-- An example is given below.+-- +-- Suppose we have a User entity defined as config/models:+-- +-- > User+-- > ident Text+-- > name Text Maybe+-- > address Text Maybe+-- > telephone Text Maybe+-- +-- Our module would then start with: +-- +-- > {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+-- > module Handler.User where+-- > +-- > import Import+-- > import Yesod.VEND+-- > +-- > import Data.Maybe+-- +-- Define helper datatype.+-- +-- > data UserP = UserP+-- +-- Provide routing. This assumes that config/routes reads:+-- +-- > /user/new UserNewR +-- > /user/edit/#UserId UserEditR +-- > /user/delete/#UserId UserDeleteR +-- > /user/view/all UserViewAllR +-- > /user/view/single/#UserId UserViewR +-- +-- Methods:+-- +-- > handleUserNewR = newR UserP+-- > handleUserDeleteR = deleteR UserP+-- > handleUserEditR = editR UserP+-- > handleUserViewR = viewR UserP+-- > handleUserViewAllR = viewAllR UserP+-- +-- Define 'EntityDeep' instance for UserId. We use default implementations.+-- +-- > instance EntityDeep UserId where+-- > type EntT UserId = User+-- > type FullEntT UserId = User+-- +-- +-- Define 'CRUD' instance for our helper type UserP. Define 'ValT' and 'KeyT' types.+-- +-- > instance CRUD UserP where+-- > type ValT UserP = User+-- > type KeyT UserP = UserId+-- > +-- +-- Wire routing information in:+-- +-- > newRt _ = UserNewR+-- > editRt _ = UserEditR+-- > deleteRt _ = UserDeleteR+-- > viewRt _ = UserViewR+-- > viewAllRt _ = UserViewAllR+-- > +-- +-- Define which 'parameters' will be displayed for entity and how:+-- +-- > params _ = [(EntityParam "Ident" userIdent id markupToWidget)+-- > ,(EntityParam "Name" userName mns mnsw)+-- > ,(EntityParam "Address" userAddress mns mnsw)+-- > ,(EntityParam "Telephone" userTelephone mns mnsw)+-- > ] where mns = fromMaybe "not set"+-- > mnsw = maybe [whamlet|<i>not set</i>|] markupToWidget+-- > +-- +-- Specify sorting in 'view all' view:+-- +-- > viewAllOptions _ = [Asc UserId]+-- > +-- +-- Define entity name:+-- +-- > entName _ = "User"+-- +-- Form for creating/editing entity:+-- +-- > form _ proto = return $ renderDivs $ +-- > User+-- > <$> areq textField "Identifier" (fmap userIdent proto)+-- > <*> aopt textField "Name" (fmap userName proto)+-- > <*> aopt textField "Address" (fmap userAddress proto)+-- > <*> aopt textField "Telephone" (fmap userTelephone proto)++module Yesod.VEND where++import Yesod++import Text.Hamlet (shamlet)+import Data.Text(Text)+import Text.Blaze.Html++import qualified Data.Text+import Database.Persist.GenericSql.Raw++-- | Datatype for providing different views on specific datatype. Transforms the parameter into intermediate datatype b from which one can use 'epToText' to get 'Text' or 'epToWidget' to get a 'GWidget'.+data EntityParam master sub a = forall b . EntityParam { epName :: Text+ , epGet :: (a -> b)+ , epToText :: (b -> Text)+ , epToWidget :: (b -> GWidget master sub ()) }++-- * Helpers to work around problems with existential types.+-- see: http://stackoverflow.com/questions/10192663/why-cant-existential-types-use-record-syntax+-- ++-- | We cannot use record syntax to access fields of existential types. Instead we have:+-- +-- > epGetText (EntityParam _ pGet pToText _) = pToText . pGet+epGetText :: EntityParam t t1 t2 -> t2 -> Text+epGetText (EntityParam _ pGet pToText _) = pToText . pGet+-- | We cannot use record syntax to access fields of existential types. Instead we have:+-- +-- > epGetWidget (EntityParam _ pGet _ pToWidget) = pToWidget . pGet+epGetWidget :: EntityParam t t1 t2 -> t2 -> GWidget t t1 ()+epGetWidget (EntityParam _ pGet _ pToWidget) = pToWidget . pGet++-- | Class for accessing entities referenced by 'a' entity type. For example for entities Foo, Bar:+-- +-- > Foo+-- > name Text+-- > Bar+-- > size Int+-- > foo FooId+-- +-- We would have this for Bar:+-- +-- > instance EntityDeep BarId where+-- > type EntT = Bar+-- > type FullEntT = (Bar,Foo)+-- > +-- > get404Full key = runDB $ do+-- > v1 <- get404 key+-- > v2 <- get404 (barFoo v1)+-- > return (v1,v2)+-- > +-- > entityCore _ = fst+-- > paramsFull _ = [(EntityParam "Size" (barSize . fst) id markupToWidget)+-- > ,(EntityParam "Foo's name" (fooName . snd) id markupToWidget)]+-- > ++class EntityDeep a where+ -- | 'base' entity type. Not critically needed but useful.+ type EntT a :: *+ type EntT a = a++ -- | 'full' entity type.+ type FullEntT a :: *+ type FullEntT a = a+++ -- | get 'full' entity from base. default implementation works akin to 'get404'.+ get404Full :: a -> GHandler master sub (FullEntT a)+ -- | return 'base' type from 'full' type+ entityCore :: a -> (FullEntT a) -> (EntT a)+ -- | get a list of parameters describing the 'full' type+ paramsFull :: a -> [EntityParam master sub (FullEntT a)]++ default entityCore :: (EntT a ~ FullEntT a) => a -> (FullEntT a) -> (EntT a)+ entityCore _ = id+ default paramsFull :: ((CRUD a), (ValT a ~ FullEntT a)) => a -> [EntityParam master sub (FullEntT a)]+ paramsFull = params+ default get404Full :: ((YesodPersistBackend sub ~ SqlPersist),+ (PersistEntity val0),+ (YesodPersist sub),+ (a ~ Key SqlPersist val0),+ (val0 ~ FullEntT (Key SqlPersist val0))) => + a -> GHandler master sub (FullEntT a)+ get404Full key = runDB (get404 key)++-- | Given description of entity parameters ('EntityParam' list) and terse/not terse option return a widget displaying the entity.+displayEntityWidget :: a -> [EntityParam master sub a] -> Bool -> GWidget master sub ()+displayEntityWidget a pars terse | terse = [whamlet| + $forall ep <- pars+ <td> ^{epGetWidget ep a} |]+ | otherwise = [whamlet|+$forall ep <- pars+ <p> #{epName ep}: + <span .param> ^{epGetWidget ep a}+ |]++-- | Core typeclass of this package. Default implementations of handlers use other methods to provide sensible default views. They can be all overriden if needed.+class (EntityDeep (KeyT a)) => CRUD a where+ -- * types + -- | entity value type+ type ValT a+ -- | entity key type+ type KeyT a++ -- * stupid methods, we cant just use (undefined :: KeyT a) because of how type families work.+ -- | provide a value of type 'KeyT a'. Default implementation is 'undefined'.+ getSomeKey :: a -> KeyT a+ getSomeKey _ = undefined+ -- | provide a value of type 'ValT a'. Default implementation is 'undefined'.+ getSomeVal :: a -> ValT a + getSomeVal _ = undefined++ -- fixme: better way to handle this?+ -- | used for sorting entities in 'view all'+ viewAllOptions :: a -> [SelectOpt (ValT a)]+ viewAllOptions _ = []+++ -- * routes+ -- | route to 'new element'+ newRt :: a -> Route site+ -- | route to 'view all elements'+ viewAllRt :: a -> Route site+ -- | route to 'view element'+ viewRt :: a -> (KeyT a) -> Route site+ -- | route to 'delete element'+ deleteRt :: a -> (KeyT a) -> Route site+ -- | route to 'edit element'+ editRt :: a -> (KeyT a) -> Route site++ -- * displaying+ -- | provide widget for displaying an element. Bool argument specifies if this is for \"terse\" view or not.+ displayWidget :: a -> (ValT a) -> Bool -> GWidget master sub ()+ -- | provide widget for displaying element header. Used in 'view all'.+ displayHeaderWidget :: a -> Bool -> GWidget master sub ()+ -- | simple version of 'paramsFull' only for 'ValT' type.+ params :: a -> [EntityParam master sub (ValT a)]++ -- * names+ -- | entity name. this will be changed in future versions to support proper internationalization.+ entName :: a -> Text++ -- * forms+ -- | form for creating new entity/editing old one.+ form :: a -> (Maybe (ValT a)) -> GHandler master sub (Html -> MForm master sub (FormResult (ValT a), (GWidget master sub ())) )+ -- | deletion form.+ dForm :: a -> GHandler master sub (Html -> MForm master sub (FormResult Bool, (GWidget master sub ())))++ -- * handlers+ -- | handler for 'viewRt'+ viewR :: a -> (KeyT a) -> GHandler master sub RepHtml+ -- | handler for 'editRt'+ editR :: a -> (KeyT a) -> GHandler master sub RepHtml+ -- | handler for 'newRt'+ newR :: a -> GHandler master sub RepHtml+ -- | handler for 'deleteRt'+ deleteR :: a -> (KeyT a) -> GHandler master sub RepHtml+ -- | handler for 'viewAllRt'+ viewAllR :: a -> GHandler master sub RepHtml++ -- default implementations++ default params :: (Show (ValT a)) => a -> [EntityParam master sub (ValT a)]+ params _ = [EntityParam "shown" show Data.Text.pack markupToWidget]++ default displayHeaderWidget :: a -> Bool -> GWidget master sub ()+ displayHeaderWidget this terse | terse = let pars = paramsFull (getSomeKey this) in [whamlet| +<tr>+ <th colspan="20"> #{entName this}+<tr>+ <th>+ Actions+ $forall ep <- pars+ <th> #{epName ep}+ |]+ | otherwise = [whamlet|+<p> #{entName this} |]++ default displayWidget :: a -> (ValT a) -> Bool -> GWidget master sub ()+ displayWidget this a terse | terse = [whamlet| + $forall ep <- params this+ <td> #{epGetText ep a} |]+ | otherwise = [whamlet|+<p> #{entName this}+$forall ep <- params this+ <p> #{epName ep}: + <span .param> #{epGetText ep a}+ |]++ default dForm :: (RenderMessage sub FormMessage) =>+ a -> GHandler master sub (Html -> MForm master sub (FormResult Bool, (GWidget master sub ())))+ dForm _this = return $ renderDivs (areq areYouSureField "Are you sure?" (Just False))+ where areYouSureField = check isSure boolField+ isSure False = Left ("You must be sure." :: Text)+ isSure True = Right True+++ default newR :: ((Yesod sub),+ (YesodPersistBackend sub ~ SqlPersist),+ (RenderMessage sub FormMessage),+ (YesodPersist sub),+ (KeyT a ~ Key SqlPersist (ValT a)),+ (PersistEntity (ValT a))) => + a -> GHandler master sub RepHtml+ newR this = do+ ((result, wg),et) <- runFormPost =<< (form this Nothing)+ let newForm = (wg,et)++ case result of+ FormSuccess val -> do+ key <- runDB $ insert val+ setMessage "Entity created."+ defaultLayout $ do+ setTitle $ toHtml $ "Created: " ++ show (entName this) ++ show key -- FIXME -- better title+ [whamlet| Creation completed. ID=#{show key}. <a href=@{viewRt this key}>View here</a>. <br>^{displayWidget this val False} |] -- FIXME - show key or not?+ _ -> defaultLayout $ do+ setTitle $ toHtml $ "New: " ++ show (entName this) -- FIXME -- better title+ [whamlet| <p .message> New: #{entName this}+<form method=post action="" enctype=#{snd newForm}>+ ^{fst newForm}+ <input type="submit"> |]++ default viewAllR :: ((YesodPersistBackend sub ~ SqlPersist),+ (YesodPersist sub),+ (Yesod sub),+ (EntityDeep (Key SqlPersist (ValT a))), + (PersistEntityBackend (ValT a) ~ SqlPersist), + (KeyT a ~ Key SqlPersist (ValT a)), + (PersistEntity (ValT a))) => a -> GHandler master sub RepHtml+ viewAllR this = do+ values <- runDB $ selectList [] (viewAllOptions this)+ values'full <- mapM (\ k -> fmap (\ v -> (k,v)) (get404Full k)) (map entityKey values)+ terse <- getTerse+ defaultLayout $ do+ setTitle $ [shamlet| All items |] -- FIXME: better title+ [whamlet| +Choose view: <a href="?terse=1">Terse</a> <a href="?terse=0">Wide</a>+<br>+<strong>+ <a href=@{newRt this}> Create new+<br>+<br>++$if terse+ <table .terse .table-striped .table .table-condensed>+ <thead>+ ^{displayHeaderWidget this terse}+ <tbody>+ $forall (key, val'full) <- values'full+ <tr>+ <td>+ <a href=@{viewRt this key}> View+ <a href=@{editRt this key}> Edit+ <a href=@{deleteRt this key}> <strong> Delete </strong>++ ^{displayEntityWidget val'full (paramsFull key) terse}+$else+ ^{displayHeaderWidget this terse}+ $forall (key, val'full) <- values'full+ <hr .listsep> + ^{displayEntityWidget val'full (paramsFull key) terse}+ <p .actions> Actions:+ <a href=@{viewRt this key}> View+ <a href=@{editRt this key}> Edit+ <a href=@{deleteRt this key}> <strong> Delete </strong>+ |]++ default viewR :: ((Yesod sub), (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master sub RepHtml+ viewR this key = do+ val'full <- get404Full key+ defaultLayout $ do+ setTitle $ toHtml $ "View: " ++ show (entName this) ++ show key -- FIXME: better title+ [whamlet| ++^{displayEntityWidget val'full (paramsFull key) False}+<p .actions> Actions:+ <a href=@{newRt this}> New+ <a href=@{editRt this key}> Edit+ <a href=@{deleteRt this key}> <strong> Delete </strong>+ |]++ + default editR :: ((YesodPersistBackend sub ~ SqlPersist),+ (YesodPersist sub),+ (Yesod sub),+ (RenderMessage sub FormMessage),+ (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master sub RepHtml+ editR this key = do+ val <- runDB $ get404 key+ ((result,fwidget), enctype) <- runFormPost =<< (form this (Just val))+ case result of+ FormSuccess new'val -> do+ runDB $ replace key new'val+ return ()+ _ -> return ()++ defaultLayout $ do+ setTitle $ toHtml $ "Edit: " ++ show (entName this) ++ show key -- FIXME -- better title+ [whamlet| +<p .actions> Actions:+ <a href=@{newRt this}> New+ <a href=@{viewRt this key}> View+ <a href=@{deleteRt this key}> <strong> Delete </strong>++<p .message> Edit: #{entName this}+<form method=post action="" enctype=#{enctype}>+ ^{fwidget}+ <input type="submit"> |]+ + default deleteR :: ((RenderMessage sub FormMessage), (YesodPersist sub), (YesodPersistBackend sub ~ SqlPersist), (Yesod sub),+ (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master sub RepHtml+ deleteR this key = do+ val'full <- get404Full key+ ((result,fwidget), enctype) <- runFormPost =<< (dForm this)+ case result of+ FormSuccess _ -> do+ runDB $ delete key+ setMessage $ [shamlet|Deleted: #{entName this} #{show key} |] -- FIXME -- more data+ defaultLayout $ do+ setTitle $ [shamlet|Deleted: #{entName this} #{show key} |] -- FIXME -- better title+ [whamlet| Delete completed. |]+ _ -> defaultLayout $ do+ setTitle $ toHtml $ "Delete: " ++ show (entName this) ++ show key -- FIXME -- better title+ [whamlet| <p .message> Delete: #{entName this}+^{displayEntityWidget val'full (paramsFull key) False}+<form method=post action="" enctype=#{enctype}>+ ^{fwidget}+ <input type="submit"> |]++-- * Utility functions++-- | Check if the view should be \"terse\" or not. Checks for \"terse\" in GET parameters. Default is True. 1 means True, 0 means False.+getTerse :: GHandler master sub Bool+getTerse = do+ p'terse <- lookupGetParam "terse"+ return $ case p'terse of+ Just "1" -> True+ Just "0" -> False+ _ -> True -- this makes terse default++-- | make 'GWidget' from any type that implements 'ToMarkup'+markupToWidget :: ToMarkup a => a -> GWidget sub master ()+markupToWidget t = [whamlet|#{t}|]++-- fst3 (v,_,_) = v+-- snd3 (_,v,_) = v+-- thr3 (_,_,v) = v
+ yesod-vend.cabal view
@@ -0,0 +1,22 @@+Name: yesod-vend+Version: 0.1+Synopsis: Simple CRUD classes for easy view creation for Yesod+Description: Simple CRUD classes for easy view creation for Yesod. See @Yesod.VEND@ for more informations and description how to use it.+License: BSD3+License-file: LICENSE+Author: Krzysztof Skrzętnicki+Maintainer: gtener@gmail.com+Category: Web, Yesod+Build-type: Simple+Cabal-version: >=1.2++Library+ Exposed-modules: Yesod.VEND+ Hs-source-dirs: src+ Build-depends: base > 4 && <5+ , yesod-platform > 1.0 && < 1.1+ , persistent+ , text+ , blaze-html+ , hamlet+ , yesod