diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Yesod/VEND.hs b/src/Yesod/VEND.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/VEND.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeFamilies, ExistentialQuantification, DefaultSignatures, QuasiQuotes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Yesod.VEND +-- Copyright : 2012 Krzysztof Skrzętnicki +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : Krzysztof Skrzętnicki +-- 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|not set|] 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 + ^{epGetWidget ep a} |] + | otherwise = [whamlet| +$forall ep <- pars +

#{epName ep}: + ^{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| + + #{entName this} + + + Actions + $forall ep <- pars + #{epName ep} + |] + | otherwise = [whamlet| +

#{entName this} |] + + default displayWidget :: a -> (ValT a) -> Bool -> GWidget master sub () + displayWidget this a terse | terse = [whamlet| + $forall ep <- params this + #{epGetText ep a} |] + | otherwise = [whamlet| +

#{entName this} +$forall ep <- params this +

#{epName ep}: + #{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}. View here.
^{displayWidget this val False} |] -- FIXME - show key or not? + _ -> defaultLayout $ do + setTitle $ toHtml $ "New: " ++ show (entName this) -- FIXME -- better title + [whamlet|

New: #{entName this} +

+ ^{fst newForm} + |] + + 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: Terse Wide +
+ + Create new +
+
+ +$if terse + + + ^{displayHeaderWidget this terse} + + $forall (key, val'full) <- values'full + +
+ View + Edit + Delete + + ^{displayEntityWidget val'full (paramsFull key) terse} +$else + ^{displayHeaderWidget this terse} + $forall (key, val'full) <- values'full +
+ ^{displayEntityWidget val'full (paramsFull key) terse} +

Actions: + View + Edit + Delete + |] + + 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} +

Actions: + New + Edit + Delete + |] + + + 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| +

Actions: + New + View + Delete + +

Edit: #{entName this} + + ^{fwidget} + |] + + 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|

Delete: #{entName this} +^{displayEntityWidget val'full (paramsFull key) False} + + ^{fwidget} + |] + +-- * 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 diff --git a/yesod-vend.cabal b/yesod-vend.cabal new file mode 100644 --- /dev/null +++ b/yesod-vend.cabal @@ -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