module Yesod.Helpers.Crud
( Item (..)
, Crud (..)
, CrudRoute (..)
, defaultCrud
) where
import Yesod.Yesod
import Yesod.Widget
import Yesod.Dispatch
import Yesod.Content
import Yesod.Handler
import Text.Hamlet
import Yesod.Form
import Language.Haskell.TH.Syntax
class Item a where
itemTitle :: a -> String
data Crud master item = Crud
{ crudSelect :: GHandler (Crud master item) master [(Key item, item)]
, crudReplace :: Key item -> item -> GHandler (Crud master item) master ()
, crudInsert :: item -> GHandler (Crud master item) master (Key item)
, crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)
, crudDelete :: Key item -> GHandler (Crud master item) master ()
}
mkYesodSub "Crud master item"
[ ClassP ''Yesod [VarT $ mkName "master"]
, ClassP ''Item [VarT $ mkName "item"]
, ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
, ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
] [$parseRoutes|
/ CrudListR GET
/add CrudAddR GET POST
/edit/#String CrudEditR GET POST
/delete/#String CrudDeleteR GET POST
|]
getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))
=> GHandler (Crud master item) master RepHtml
getCrudListR = do
items <- getYesodSub >>= crudSelect
toMaster <- getRouteToMaster
defaultLayout $ do
setTitle "Items"
addWidget [$hamlet|
%h1 Items
%ul
$forall items item
%li
%a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@
$itemTitle.snd.item$
%p
%a!href=@toMaster.CrudAddR@ Add new item
|]
getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> GHandler (Crud master item) master RepHtml
getCrudAddR = crudHelper
"Add new"
(Nothing :: Maybe (Key item, item))
False
postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> GHandler (Crud master item) master RepHtml
postCrudAddR = crudHelper
"Add new"
(Nothing :: Maybe (Key item, item))
True
getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> String -> GHandler (Crud master item) master RepHtml
getCrudEditR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
item <- crudGet crud itemId >>= maybe notFound return
crudHelper
"Edit item"
(Just (itemId, item))
False
postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> String -> GHandler (Crud master item) master RepHtml
postCrudEditR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
item <- crudGet crud itemId >>= maybe notFound return
crudHelper
"Edit item"
(Just (itemId, item))
True
getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
=> String -> GHandler (Crud master item) master RepHtml
getCrudDeleteR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
item <- crudGet crud itemId >>= maybe notFound return
toMaster <- getRouteToMaster
defaultLayout $ do
setTitle "Confirm delete"
addWidget [$hamlet|
%form!method=post!action=@toMaster.CrudDeleteR.s@
%h1 Really delete?
%p Do you really want to delete $itemTitle.item$?
%p
%input!type=submit!value=Yes
\ $
%a!href=@toMaster.CrudListR@ No
|]
postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
=> String -> GHandler (Crud master item) master RepHtml
postCrudDeleteR s = do
itemId <- maybe notFound return $ itemReadId s
crud <- getYesodSub
toMaster <- getRouteToMaster
crudDelete crud itemId
redirect RedirectTemporary $ toMaster CrudListR
itemReadId :: SinglePiece x => String -> Maybe x
itemReadId = either (const Nothing) Just . fromSinglePiece
crudHelper
:: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
=> String -> Maybe (Key a, a) -> Bool
-> GHandler (Crud master a) master RepHtml
crudHelper title me isPost = do
crud <- getYesodSub
(errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me
toMaster <- getRouteToMaster
case (isPost, errs) of
(True, FormSuccess a) -> do
eid <- case me of
Just (eid, _) -> do
crudReplace crud eid a
return eid
Nothing -> crudInsert crud a
redirect RedirectTemporary $ toMaster $ CrudEditR
$ toSinglePiece eid
_ -> return ()
defaultLayout $ do
setTitle $ string title
addWidget [$hamlet|
%p
%a!href=@toMaster.CrudListR@ Return to list
%h1 $title$
%form!method=post!enctype=$enctype$
%table
^form^
%tr
%td!colspan=2
$hidden$
%input!type=submit
$maybe me e
\ $
%a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
|]
defaultCrud
:: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)),
YesodPersist a)
=> a -> Crud a i
defaultCrud = const Crud
{ crudSelect = runDB $ selectList [] [] 0 0
, crudReplace = \a -> runDB . replace a
, crudInsert = runDB . insert
, crudGet = runDB . get
, crudDelete = runDB . delete
}