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
data EntityParam master sub a = forall b . EntityParam { epName :: Text
, epGet :: (a -> b)
, epToText :: (b -> Text)
, epToWidget :: (b -> GWidget master sub ()) }
epGetText :: EntityParam t t1 t2 -> t2 -> Text
epGetText (EntityParam _ pGet pToText _) = pToText . pGet
epGetWidget :: EntityParam t t1 t2 -> t2 -> GWidget t t1 ()
epGetWidget (EntityParam _ pGet _ pToWidget) = pToWidget . pGet
class EntityDeep a where
type EntT a :: *
type EntT a = a
type FullEntT a :: *
type FullEntT a = a
get404Full :: a -> GHandler master sub (FullEntT a)
entityCore :: a -> (FullEntT a) -> (EntT a)
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)
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}
|]
class (EntityDeep (KeyT a)) => CRUD a where
type ValT a
type KeyT a
getSomeKey :: a -> KeyT a
getSomeKey _ = undefined
getSomeVal :: a -> ValT a
getSomeVal _ = undefined
viewAllOptions :: a -> [SelectOpt (ValT a)]
viewAllOptions _ = []
newRt :: a -> Route site
viewAllRt :: a -> Route site
viewRt :: a -> (KeyT a) -> Route site
deleteRt :: a -> (KeyT a) -> Route site
editRt :: a -> (KeyT a) -> Route site
displayWidget :: a -> (ValT a) -> Bool -> GWidget master sub ()
displayHeaderWidget :: a -> Bool -> GWidget master sub ()
params :: a -> [EntityParam master sub (ValT a)]
entName :: a -> Text
form :: a -> (Maybe (ValT a)) -> GHandler master sub (Html -> MForm master sub (FormResult (ValT a), (GWidget master sub ())) )
dForm :: a -> GHandler master sub (Html -> MForm master sub (FormResult Bool, (GWidget master sub ())))
viewR :: a -> (KeyT a) -> GHandler master sub RepHtml
editR :: a -> (KeyT a) -> GHandler master sub RepHtml
newR :: a -> GHandler master sub RepHtml
deleteR :: a -> (KeyT a) -> GHandler master sub RepHtml
viewAllR :: a -> GHandler master sub RepHtml
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
[whamlet| Creation completed. ID=#{show key}. <a href=@{viewRt this key}>View here</a>. <br>^{displayWidget this val False} |]
_ -> defaultLayout $ do
setTitle $ toHtml $ "New: " ++ show (entName this)
[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 |]
[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 .tablestriped .table .tablecondensed>
<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
[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
[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} |]
defaultLayout $ do
setTitle $ [shamlet|Deleted: #{entName this} #{show key} |]
[whamlet| Delete completed. |]
_ -> defaultLayout $ do
setTitle $ toHtml $ "Delete: " ++ show (entName this) ++ show key
[whamlet| <p .message> Delete: #{entName this}
^{displayEntityWidget val'full (paramsFull key) False}
<form method=post action="" enctype=#{enctype}>
^{fwidget}
<input type="submit"> |]
getTerse :: GHandler master sub Bool
getTerse = do
p'terse <- lookupGetParam "terse"
return $ case p'terse of
Just "1" -> True
Just "0" -> False
_ -> True
markupToWidget :: ToMarkup a => a -> GWidget sub master ()
markupToWidget t = [whamlet|#{t}|]