yesod-crud-persist 0.1.2 → 0.2.1
raw patch · 4 files changed
+433/−137 lines, 4 filesdep +eitherdep +esqueletodep +microlensdep −lens
Dependencies added: either, esqueleto, microlens, microlens-th, time, yesod-markdown
Dependencies removed: lens
Files
- src/Yesod/Crud.hs +193/−81
- src/Yesod/Crud/Simple.hs +136/−53
- src/Yesod/Crud/Simple/Generic.hs +92/−0
- yesod-crud-persist.cabal +12/−3
src/Yesod/Crud.hs view
@@ -4,121 +4,233 @@ import Control.Applicative import Data.Maybe +import Lens.Micro.TH+ import Yesod.Core-import Database.Persist(Key)+import Database.Persist (Key) import Network.Wai (pathInfo, requestMethod)+import Yesod.Persist hiding (Key)+import Database.Persist.Sql+import Data.Foldable (for_)+import Data.Text (Text)+import Data.Monoid import qualified Data.List as List+import qualified Database.Esqueleto as E import Yesod.Crud.Internal+import Data.Typeable+import Data.Proxy+import Unsafe.Coerce (unsafeCoerce) -data Crud master a = Crud- { _chAdd :: HandlerT (Crud master a) (HandlerT master IO) Html- , _chIndex :: HandlerT (Crud master a) (HandlerT master IO) Html- , _chEdit :: Key a -> HandlerT (Crud master a) (HandlerT master IO) Html- , _chDelete :: Key a -> HandlerT (Crud master a) (HandlerT master IO) Html+-- In Crud, c is the child type, and p is the type of the identifier+-- for its parent.+data Crud master p c = Crud+ { _ccAdd :: p -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _ccIndex :: p -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _ccEdit :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _ccDelete :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _ccView :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html }+makeLenses ''Crud --- Dispatch for the crud subsite-instance (Eq (Key a), PathPiece (Key a)) => YesodSubDispatch (Crud master a) (HandlerT master IO) where+breadcrumbsCrud :: PersistCrudEntity master c+ => (Route (Crud master p c) -> Route master) + -> Route (Crud master p c) + -> Text+ -> (c -> Text)+ -> (Key c -> YesodDB master p)+ -> (p -> HandlerT master IO (Maybe (Route master))) + -> HandlerT master IO (Text, Maybe (Route master))+breadcrumbsCrud tp route indexName getName getParent getIndexParent = case route of+ AddR p -> return ("Add", Just $ tp $ IndexR p)+ IndexR p -> do+ indexParent <- getIndexParent p+ return (indexName, indexParent)+ ViewR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return ("View - " <> getName c, Just $ tp $ IndexR p)+ EditR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return ("Edit - " <> getName c, Just $ tp $ IndexR p)+ DeleteR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return ("Delete - " <> getName c, Just $ tp $ IndexR p)++breadcrumbsCrudHierarchy :: (PersistCrudEntity master a, SqlClosure a c)+ => (Route (Crud master (Maybe (Key a)) a) -> Route master) + -> Route (Crud master (Maybe (Key a)) a) + -> Text+ -> Maybe (Route master)+ -> (a -> Text)+ -> HandlerT master IO (Text, Maybe (Route master))+breadcrumbsCrudHierarchy tp route indexName parent getName = case route of+ AddR p -> return ("Add", Just $ tp $ IndexR p)+ ViewR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ closureGetParentId cid+ return ("View - " <> getName c, Just $ tp $ IndexR p)+ EditR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ closureGetParentId cid+ return ("Edit - " <> getName c, Just $ tp $ IndexR p)+ DeleteR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ closureGetParentId cid+ return ("Delete - " <> getName c, Just $ tp $ IndexR p)+ IndexR Nothing -> return (indexName, parent)+ IndexR (Just cid) -> do+ c <- runDB $ get404 cid+ p <- runDB $ closureGetParentId cid+ return (getName c, Just . tp . IndexR $ p)++-- By using this, you will trade some type safety+data SomeCrud master = forall p c. (Typeable p, Typeable c) => SomeCrud (Crud master p c)++findCrud :: forall p c master. (Typeable p, Typeable c) => [SomeCrud master] -> Crud master p c+findCrud = fromJust . go + where+ go (SomeCrud (crud :: Crud master p1 c1):cs) = + if typeRep (Proxy :: Proxy p1) == typeRep (Proxy :: Proxy p)+ && typeRep (Proxy :: Proxy c1) == typeRep (Proxy :: Proxy c)+ then Just (unsafeCoerce crud)+ else go cs+ go [] = Nothing++-- Dispatch for the child crud subsite+instance (Eq (Key c), PathPiece (Key c), Eq p, PathPiece p) => YesodSubDispatch (Crud master p c) (HandlerT master IO) where yesodSubDispatch env req = h where h = let parsed = parseRoute (pathInfo req, []) helper a = subHelper (fmap toTypedContent a) env parsed req in case parsed of- Just (EditR theId) -> onlyAllow ["GET","POST"] $ helper $ - getYesod >>= (\s -> _chEdit s theId)- Just (DeleteR theId) -> onlyAllow ["GET","POST"] $ helper $ - getYesod >>= (\s -> _chDelete s theId)- Just AddR -> onlyAllow ["GET","POST"] $ helper $- getYesod >>= _chAdd- Just IndexR -> onlyAllow ["GET"] $ helper $- getYesod >>= _chIndex+ Just (EditR theId) -> onlyAllow ["GET","POST"]+ $ helper $ getYesod >>= (\s -> _ccEdit s theId)+ Just (DeleteR theId) -> onlyAllow ["GET","POST"] + $ helper $ getYesod >>= (\s -> _ccDelete s theId)+ Just (AddR p) -> onlyAllow ["GET","POST"] + $ helper $ getYesod >>= (\s -> _ccAdd s p)+ Just (IndexR p) -> onlyAllow ["GET"] + $ helper $ getYesod >>= (\s -> _ccIndex s p)+ Just (ViewR theId) -> onlyAllow ["GET"] + $ helper $ getYesod >>= (\s -> _ccView s theId) Nothing -> notFoundApp onlyAllow reqTypes waiApp = if isJust (List.find (== requestMethod req) reqTypes) then waiApp else notFoundApp notFoundApp = subHelper (fmap toTypedContent notFoundUnit) env Nothing req notFoundUnit = fmap (\() -> ()) notFound -instance (PathPiece (Key a), Eq (Key a)) => RenderRoute (Crud master a) where- data Route (Crud master a)- = EditR (Key a)- | DeleteR (Key a)- | IndexR- | AddR+instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => RenderRoute (Crud master p c) where+ data Route (Crud master p c)+ = EditR (Key c)+ | DeleteR (Key c)+ | IndexR p+ | AddR p+ | ViewR (Key c) renderRoute r = noParams $ case r of- EditR theId -> ["edit", toPathPiece theId]+ EditR theId -> ["edit", toPathPiece theId] DeleteR theId -> ["delete", toPathPiece theId]- IndexR -> ["index"]- AddR -> ["add"]+ IndexR p -> ["index", toPathPiece p]+ AddR p -> ["add", toPathPiece p]+ ViewR theId -> ["view", toPathPiece theId] where noParams xs = (xs,[]) -instance (Eq (Key a), PathPiece (Key a)) => ParseRoute (Crud master a) where+instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => ParseRoute (Crud master p c) where parseRoute (_, (_:_)) = Nothing parseRoute (xs, []) = Nothing <|> (runSM xs $ pure EditR <* consumeMatchingText "edit" <*> consumeKey) <|> (runSM xs $ pure DeleteR <* consumeMatchingText "delete" <*> consumeKey)- <|> (runSM xs $ pure IndexR <* consumeMatchingText "index")- <|> (runSM xs $ pure AddR <* consumeMatchingText "add")+ <|> (runSM xs $ pure IndexR <* consumeMatchingText "index" <*> consumeKey)+ <|> (runSM xs $ pure AddR <* consumeMatchingText "add" <*> consumeKey)+ <|> (runSM xs $ pure ViewR <* consumeMatchingText "view" <*> consumeKey) +deriving instance (Eq (Key c), Eq p) => Eq (Route (Crud master p c))+deriving instance (Show (Key c), Show p) => Show (Route (Crud master p c))+deriving instance (Read (Key c), Read p) => Read (Route (Crud master p c)) -deriving instance Eq (Key a) => Eq (Route (Crud master a))-deriving instance Show (Key a) => Show (Route (Crud master a))-deriving instance Read (Key a) => Read (Route (Crud master a))+type HierarchyCrud master a = Crud master (Maybe (Key a)) a --- In ChildCrud, c is the child type, and p is the type of the identifier--- for its parent.-data ChildCrud master p c = ChildCrud- { _ccAdd :: p -> HandlerT (ChildCrud master p c) (HandlerT master IO) Html- , _ccIndex :: p -> HandlerT (ChildCrud master p c) (HandlerT master IO) Html- , _ccEdit :: Key c -> HandlerT (ChildCrud master p c) (HandlerT master IO) Html- , _ccDelete :: Key c -> HandlerT (ChildCrud master p c) (HandlerT master IO) Html- }+class (NodeTable c ~ a, ClosureTable a ~ c) => ClosureTablePair a c where+ type NodeTable c+ type ClosureTable a+ closureAncestorCol :: EntityField c (Key a)+ closureDescendantCol :: EntityField c (Key a)+ closureDepthCol :: EntityField c Int+ closureAncestor :: c -> Key a+ closureDescendant :: c -> Key a+ closureDepth :: c -> Int+ closureCreate :: Key a -> Key a -> Int -> c -type HierarchyCrud master a = ChildCrud master (Maybe (Key a)) a+type PersistCrudEntity master a =+ ( PathPiece (Key a) + , Yesod master+ , YesodPersist master+ , PersistEntity a+ , PersistQuery (YesodPersistBackend master)+ , PersistEntityBackend a ~ YesodPersistBackend master+ ) --- Dispatch for the child crud subsite-instance (Eq (Key c), PathPiece (Key c), Eq p, PathPiece p) => YesodSubDispatch (ChildCrud master p c) (HandlerT master IO) where- yesodSubDispatch env req = h- where - h = let parsed = parseRoute (pathInfo req, []) - helper a = subHelper (fmap toTypedContent a) env parsed req- in case parsed of- Just (ChildEditR theId) -> onlyAllow ["GET","POST"]- $ helper $ getYesod >>= (\s -> _ccEdit s theId)- Just (ChildDeleteR theId) -> onlyAllow ["GET","POST"] - $ helper $ getYesod >>= (\s -> _ccDelete s theId)- Just (ChildAddR p) -> onlyAllow ["GET","POST"] - $ helper $ getYesod >>= (\s -> _ccAdd s p)- Just (ChildIndexR p) -> onlyAllow ["GET"] - $ helper $ getYesod >>= (\s -> _ccIndex s p)- Nothing -> notFoundApp- onlyAllow reqTypes waiApp = if isJust (List.find (== requestMethod req) reqTypes) then waiApp else notFoundApp- notFoundApp = subHelper (fmap toTypedContent notFoundUnit) env Nothing req- notFoundUnit = fmap (\() -> ()) notFound+type SqlClosure a c = + ( ClosureTablePair a c+ , PersistEntityBackend a ~ SqlBackend+ , PersistEntityBackend (ClosureTable a) ~ SqlBackend+ , PersistEntity a+ , PersistEntity c+ , PersistField (Key a)+ ) -instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => RenderRoute (ChildCrud master p c) where- data Route (ChildCrud master p c)- = ChildEditR (Key c)- | ChildDeleteR (Key c)- | ChildIndexR p- | ChildAddR p- renderRoute r = noParams $ case r of- ChildEditR theId -> ["edit", toPathPiece theId]- ChildDeleteR theId -> ["delete", toPathPiece theId]- ChildIndexR p -> ["index", toPathPiece p]- ChildAddR p -> ["add", toPathPiece p]- where noParams xs = (xs,[])+closureDepthColAs :: forall a c. ClosureTablePair a c + => Key a -> EntityField c Int+closureDepthColAs _ = (closureDepthCol :: EntityField c Int) -instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => ParseRoute (ChildCrud master p c) where- parseRoute (_, (_:_)) = Nothing- parseRoute (xs, []) = Nothing- <|> (runSM xs $ pure ChildEditR <* consumeMatchingText "edit" <*> consumeKey)- <|> (runSM xs $ pure ChildDeleteR <* consumeMatchingText "delete" <*> consumeKey)- <|> (runSM xs $ pure ChildIndexR <* consumeMatchingText "index" <*> consumeKey)- <|> (runSM xs $ pure ChildAddR <* consumeMatchingText "add" <*> consumeKey)+closureGetRootNodes :: (MonadIO m, SqlClosure a c) => SqlPersistT m [Entity a]+closureGetRootNodes = E.select $ E.from $ \a -> do+ E.where_ $ E.notExists $ E.from $ \c -> do+ E.where_ $ c E.^. closureDescendantCol E.==. a E.^. persistIdField+ E.&&. c E.^. closureDepthCol E.>. E.val 0+ return a -deriving instance (Eq (Key c), Eq p) => Eq (Route (ChildCrud master p c))-deriving instance (Show (Key c), Show p) => Show (Route (ChildCrud master p c))-deriving instance (Read (Key c), Read p) => Read (Route (ChildCrud master p c))+-- This includes the child itself, the root comes first+closureGetParents :: (MonadIO m, SqlClosure a c) => Key a -> SqlPersistT m [Entity a]+closureGetParents theId = E.select $ E.from $ \(a `E.InnerJoin` c) -> do+ E.on $ a E.^. persistIdField E.==. c E.^. closureAncestorCol+ E.where_ $ c E.^. closureDescendantCol E.==. E.val theId+ E.orderBy [E.desc $ c E.^. closureDepthCol]+ return a +closureGetMaybeImmidiateChildren :: (MonadIO m, SqlClosure a c)+ => Maybe (Key a) -> SqlPersistT m [Entity a]+closureGetMaybeImmidiateChildren Nothing = closureGetRootNodes+closureGetMaybeImmidiateChildren (Just k) = closureGetImmidiateChildren k +closureGetImmidiateChildren :: (MonadIO m, SqlClosure a c) + => Key a -> SqlPersistT m [Entity a]+closureGetImmidiateChildren theId = do+ cs <- selectList [closureAncestorCol ==. theId, closureDepthCol ==. 1] []+ selectList [persistIdField <-. map (closureDescendant . entityVal) cs] [Asc persistIdField]++closureGetParentId :: (MonadIO m, SqlClosure a c) + => Key a -> SqlPersistT m (Maybe (Key a))+closureGetParentId theId = do+ cs <- selectList [closureDescendantCol ==. theId, closureDepthCol ==. 1] []+ return $ fmap (closureAncestor . entityVal) $ listToMaybe cs++closureGetParentIdProxied :: (MonadIO m, SqlClosure a c) + => p c -> Key a -> SqlPersistT m (Maybe (Key a))+closureGetParentIdProxied _ = closureGetParentId++closureInsert :: forall m a c. (MonadIO m, SqlClosure a c) + => Maybe (Key a) -> a -> SqlPersistT m (Key a)+closureInsert mparent a = do+ childId <- insert a+ _ <- insert $ closureCreate childId childId 0 + for_ mparent $ \parentId -> do+ cs <- selectList [closureDescendantCol ==. parentId] []+ insertMany_ $ map (\(Entity _ c) -> + closureCreate (closureAncestor c) childId (closureDepth c + 1)) cs + return childId++closureRootNodes :: (MonadIO m, SqlClosure a c) => SqlPersistT m [Entity a]+closureRootNodes = error "Write this" -- probably with esqueleto
src/Yesod/Crud/Simple.hs view
@@ -2,41 +2,109 @@ import Prelude import Data.Monoid-import Control.Lens.TH-import Control.Lens hiding (index)+import Lens.Micro+import Lens.Micro.TH import Yesod.Core import Yesod.Form import Yesod.Persist+import Database.Persist.Sql import Data.Text (Text)+import Control.Monad+import Data.Proxy import Yesod.Crud -data SimpleCrud master a = SimpleCrud- { _scAdd :: WidgetT master IO () -> HandlerT (Crud master a) (HandlerT master IO) Html- , _scIndex :: HandlerT (Crud master a) (HandlerT master IO) Html- , _scEdit :: WidgetT master IO () -> HandlerT (Crud master a) (HandlerT master IO) Html- , _scDelete :: WidgetT master IO () -> HandlerT (Crud master a) (HandlerT master IO) Html+data SimpleCrud master p c = SimpleCrud+ { _scAdd :: WidgetT master IO () -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _scIndex :: p -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _scView :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _scEdit :: WidgetT master IO () -> HandlerT (Crud master p c) (HandlerT master IO) Html+ , _scDelete :: WidgetT master IO () -> HandlerT (Crud master p c) (HandlerT master IO) Html , _scDeleteForm :: WidgetT master IO () - , _scForm :: Maybe a -> Html -> MForm (HandlerT master IO) (FormResult a, WidgetT master IO ())+ , _scForm :: Either p c -> Html -> MForm (HandlerT master IO) (FormResult c, WidgetT master IO ()) , _scFormWrap :: Enctype -> Route master -> WidgetT master IO () -> WidgetT master IO ()+ , _scDeleteDb :: Key c -> YesodDB master p+ , _scAddDb :: p -> c -> YesodDB master (Key c)+ , _scEditDb :: Key c -> c -> YesodDB master p } makeLenses ''SimpleCrud -emptySimpleCrud :: SimpleCrud master a-emptySimpleCrud = SimpleCrud (const $ return mempty) (return mempty) (const $ return mempty) (const $ return mempty) - mempty (const $ const $ return (FormMissing,mempty)) (const $ const $ const mempty) +emptyParentlessSimpleCrud :: + PathPiece (Key a) + => Yesod master+ => YesodPersist master+ => PersistEntity a+ => PersistQuery (YesodPersistBackend master)+ => PersistEntityBackend a ~ YesodPersistBackend master+ => SimpleCrud master () a+emptyParentlessSimpleCrud = SimpleCrud + (const $ return mempty) -- add + (const $ return mempty) -- index+ (const $ return mempty) -- view+ (const $ return mempty) -- edit+ (const $ return mempty) -- delete+ mempty (const $ const $ return (FormMissing,mempty)) -- delete form+ (const $ const $ const mempty) -- form wrapper+ delete -- default deletion, assumes no FK constraints+ (const insert) -- default DB add+ replace -- default DB edit -basicSimpleCrud :: forall master a. +emptyChildSimpleCrud :: PathPiece (Key a) => Yesod master => YesodPersist master => PersistEntity a => PersistQuery (YesodPersistBackend master) => PersistEntityBackend a ~ YesodPersistBackend master- => SimpleCrud master a-basicSimpleCrud = emptySimpleCrud- & scIndex .~ index+ => (Key a -> YesodDB master p) -> SimpleCrud master p a+emptyChildSimpleCrud getParent = SimpleCrud + (const $ return mempty) -- add + (const $ return mempty) -- index+ (const $ return mempty) -- view+ (const $ return mempty) -- edit+ (const $ return mempty) -- delete+ mempty (const $ const $ return (FormMissing,mempty)) -- delete form+ (const $ const $ const mempty) -- form wrapper+ del -- default deletion, assumes no FK constraints+ (const insert) -- default DB add+ edit -- default DB edit+ where + del k = do+ p <- getParent k+ delete k+ return p+ edit k v = do+ replace k v+ getParent k++emptyHierarchySimpleCrud :: forall a c master.+ SqlBackend ~ YesodPersistBackend master+ => PersistStore (YesodPersistBackend master)+ => YesodPersist master+ => SqlClosure a c+ => SimpleCrud master (Maybe (Key a)) a +emptyHierarchySimpleCrud = SimpleCrud+ (const $ return mempty) -- add + (const $ return mempty) -- index+ (const $ return mempty) -- view+ (const $ return mempty) -- edit+ (const $ return mempty) -- delete+ mempty (const $ const $ return (FormMissing,mempty)) -- delete form+ (const $ const $ const mempty) -- form wrapper+ del -- deletion+ closureInsert -- default DB add+ edit -- default DB edit+ where + del k = closureGetParentIdProxied (Proxy :: Proxy c) k+ edit k v = do+ replace k v+ closureGetParentIdProxied (Proxy :: Proxy c) k++applyBasicLayoutsAndForms :: PersistCrudEntity master a+ => SimpleCrud master p a -> SimpleCrud master p a+applyBasicLayoutsAndForms initial = initial+ & scIndex .~ basicSimpleCrudIndex (toWidget . toHtml . toPathPiece . entityKey) & scAdd .~ lift . defaultLayout & scEdit .~ lift . defaultLayout & scDelete .~ lift . defaultLayout@@ -46,73 +114,88 @@ <form action="@{route}" enctype="#{enctype}" method="post"> ^{inner} |]- index :: HandlerT (Crud master a) (HandlerT master IO) Html - index = do- tp <- getRouteToParent- as <- lift $ runDB $ selectList [] []- let _ = as :: [Entity a]- lift $ defaultLayout $ [whamlet|$newline never- <h1>Index- <p>- <a href="@{tp AddR}">Add- <table>- <thead>- <tr>- <th>ID- <th>Edit- <th>Delete- <tbody>- $forall (Entity theId _) <- as- <tr>- <td>#{toPathPiece theId}- <td>- <a href="@{tp (EditR theId)}">Edit- <td>- <a href="@{tp (DeleteR theId)}">Delete- |] -simpleCrudToCrud :: PersistEntityBackend a ~ YesodPersistBackend master+basicSimpleCrudIndex :: (PersistCrudEntity site c)+ => (Entity c -> WidgetT site IO ()) -> p -> HandlerT (Crud site p c) (HandlerT site IO) Html+basicSimpleCrudIndex nameFunc p = do+ tp <- getRouteToParent+ cs <- lift $ runDB $ selectList [] []+ lift $ defaultLayout $ [whamlet|$newline never+ <h1>Index+ <p>+ <a href="@{tp (AddR p)}">Add+ <table.table>+ <thead>+ <tr>+ <th>ID+ <th>Edit+ <th>Delete+ <tbody>+ $forall c <- cs+ <tr>+ <td>^{nameFunc c}+ <td>+ <a href="@{tp (EditR (entityKey c))}">Edit+ <td>+ <a href="@{tp (DeleteR (entityKey c))}">Delete+ |]++++basicSimpleCrud :: PersistCrudEntity master a => SimpleCrud master () a+basicSimpleCrud = applyBasicLayoutsAndForms emptyParentlessSimpleCrud++basicChildSimpleCrud :: PersistCrudEntity master a => (Key a -> YesodDB master p) -> SimpleCrud master p a+basicChildSimpleCrud f = applyBasicLayoutsAndForms (emptyChildSimpleCrud f)++basicHierarchySimpleCrud :: (PersistCrudEntity master a, SqlClosure a c)+ => SimpleCrud master (Maybe (Key a)) a+basicHierarchySimpleCrud = applyBasicLayoutsAndForms emptyHierarchySimpleCrud++simpleCrudToCrud :: + PersistEntityBackend a ~ YesodPersistBackend master => PersistEntity a => PersistStore (YesodPersistBackend master) => YesodPersist master => RenderMessage master FormMessage- => SimpleCrud master a -> Crud master a-simpleCrudToCrud (SimpleCrud add index edit del delForm form wrap) = - Crud addH indexH editH delH+ => SimpleCrud master p a -> Crud master p a+simpleCrudToCrud (SimpleCrud add index view edit del delForm form wrap delDb addDb editDb) = + Crud addH indexH editH delH viewH where indexH = index+ viewH = view delH theId = do tp <- getRouteToParent lift $ do res <- runInputPostResult $ ireq textField "fake" case res of FormSuccess _ -> do- runDB $ delete theId+ p <- runDB $ delDb theId setMessageI ("You have deleted the resource." :: Text)- redirect (tp IndexR)+ redirect (tp $ IndexR p) _ -> return () del (wrap UrlEncoded (tp $ DeleteR theId) ([whamlet|<input type="hidden" value="a" name="fake">|] <> delForm))- addH = do + addH p = do tp <- getRouteToParent (enctype,w) <- lift $ do- ((res,w),enctype) <- runFormPost (form Nothing)+ ((res,w),enctype) <- runFormPost (form $ Left p) case res of FormSuccess a -> do- runDB $ insert_ a + void $ runDB $ addDb p a setMessageI ("You have created a new resource." :: Text)- redirect (tp IndexR)+ redirect (tp $ IndexR p) _ -> return (enctype,w)- add (wrap enctype (tp AddR) w)+ add (wrap enctype (tp $ AddR p) w) editH theId = do tp <- getRouteToParent (enctype,w) <- lift $ do old <- runDB $ get404 theId- ((res,w),enctype) <- runFormPost (form $ Just old)+ ((res,w),enctype) <- runFormPost (form $ Right old) case res of FormSuccess new -> do- runDB $ replace theId new+ p <- runDB $ editDb theId new setMessageI ("You have updated the resource." :: Text)- redirect (tp IndexR)+ redirect (tp $ IndexR p) _ -> return (enctype,w) edit (wrap enctype (tp $ EditR theId) w)
+ src/Yesod/Crud/Simple/Generic.hs view
@@ -0,0 +1,92 @@+module Yesod.Crud.Simple.Generic where++import Prelude+import Yesod.Crud+import Yesod.Crud.Simple+import Yesod.Core+import Yesod.Form+import Yesod.Form.Bootstrap3+import GHC.Generics+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Char (isLower)+import Database.Persist+import Database.Persist.Sql+import Yesod.Persist+import Data.Either.Combinators+import Data.Time+import Yesod.Markdown++class HasName a where+ gcrudName :: a -> Text+ gcrudNameField :: EntityField a Text++class GCrud c where+ gcrudForm :: (Yesod site, YesodPersist site, YesodPersistBackend site ~ SqlBackend, m ~ HandlerT site IO, MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Maybe c -> AForm m c++-- instance GCrud (U1 p) where+-- gcrudForm _ = return (FormSuccess U1, mempty)++instance (GCrud (f p), GCrud (g p)) => GCrud ((:*:) f g p) where+ gcrudForm m = case m of+ Just (a :*: b) -> (:*:) <$> gcrudForm (Just a) <*> gcrudForm (Just b)+ Nothing -> (:*:) <$> gcrudForm Nothing <*> gcrudForm Nothing++instance (GCrud (f p)) => GCrud (M1 D b f p) where+ gcrudForm m = fmap M1 . gcrudForm $ fmap unM1 m++instance (GCrud (f p)) => GCrud (M1 C b f p) where+ gcrudForm m = fmap M1 . gcrudForm $ fmap unM1 m++instance (Selector b, GCrudNamed c) => GCrud (M1 S b (K1 R c) p) where+ gcrudForm m = let lbl = Text.pack $ selName (undefined :: M1 S b (K1 R c) ()) in+ fmap (M1 . K1) $ case m of+ Just (M1 (K1 c)) -> gcrudFormNamed lbl (Just c)+ Nothing -> gcrudFormNamed lbl Nothing++class GCrudNamed c where+ gcrudFormNamed :: (Yesod site, YesodPersist site, YesodPersistBackend site ~ SqlBackend, m ~ HandlerT site IO, MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Text -> Maybe c -> AForm m c++instance GCrudNamed Markdown where+ gcrudFormNamed lbl m = areq markdownField (bfs $ Text.dropWhile isLower lbl) m++instance GCrudNamed Text where+ gcrudFormNamed lbl m = areq textField (bfs $ Text.dropWhile isLower lbl) m++instance GCrudNamed Day where+ gcrudFormNamed lbl m = areq dayField (bfs $ Text.dropWhile isLower lbl) m++instance GCrudNamed [Text] where+ gcrudFormNamed lbl m = areq (convertField (Text.splitOn " ") (Text.intercalate " ") textField) (bfs $ Text.dropWhile isLower lbl) m++instance GCrudNamed Int where+ gcrudFormNamed lbl m = areq intField (bfs $ Text.dropWhile isLower lbl) m++instance (HasName a, Eq (Key a), PathPiece (Key a), PersistEntity a, PersistEntityBackend a ~ SqlBackend) => GCrudNamed (Key a) where+ gcrudFormNamed lbl m = areq (selectField genericNamedOpts) (bfs $ Text.dropWhile isLower lbl) m++applyGenericForm :: (Yesod master, Generic c, GCrud (Rep c ()), RenderMessage master FormMessage, YesodPersist master, YesodPersistBackend master ~ SqlBackend)+ => SimpleCrud master p c -> SimpleCrud master p c+applyGenericForm sc = sc+ { _scForm = \e -> let m = rightToMaybe e in renderBootstrap3 BootstrapBasicForm $ id+ <$> (fmap to (gcrudForm (fmap from' m))) + <* bootstrapSubmit ("Submit" :: BootstrapSubmit Text)+ }+ where from' :: Generic a => a -> Rep a ()+ from' = from -- A hack to stop the type checker from whining about p++genericForm :: (Yesod master, Generic a, GCrud (Rep a ()), RenderMessage master FormMessage, YesodPersist master, YesodPersistBackend master ~ SqlBackend) + => Maybe a -> Html -> MForm (HandlerT master IO) (FormResult a, WidgetT master IO ())+genericForm m = renderBootstrap3 BootstrapBasicForm $ id+ <$> (fmap to (gcrudForm (fmap from' m))) + <* bootstrapSubmit ("Submit" :: BootstrapSubmit Text)+ where from' :: Generic a => a -> Rep a ()+ from' = from -- A hack to stop the type checker from whining about p++genericIndex :: (PersistCrudEntity site c, HasName c)+ => p -> HandlerT (Crud site p c) (HandlerT site IO) Html+genericIndex = basicSimpleCrudIndex (toWidget . toHtml . gcrudName . entityVal)++genericNamedOpts :: (PersistCrudEntity site c, HasName c) => HandlerT site IO (OptionList (Key c))+genericNamedOpts = optionsPersistKey [] [Asc gcrudNameField] gcrudName+
yesod-crud-persist.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-crud-persist-version: 0.1.2+version: 0.2.1 synopsis: Flexible CRUD subsite usable with Yesod and Persistent. description: Flexible CRUD subsite usable with Yesod and Persistent. homepage: https://github.com/andrewthad/yesod-crud-persist@@ -21,13 +21,19 @@ , yesod-core >= 1.4.11 , yesod-form >= 1.2 , yesod-persistent >= 1.2- , persistent >= 1.2- , lens >= 4.0+ , yesod-markdown + , persistent >= 1.2+ , microlens >= 0.1.0+ , microlens-th >= 0.1.0 , text , transformers >= 0.3.0 , wai >= 2.0+ , esqueleto >= 2.0+ , either+ , time exposed-modules: Yesod.Crud , Yesod.Crud.Simple+ , Yesod.Crud.Simple.Generic , Yesod.Crud.Internal default-extensions: QuasiQuotes , TemplateHaskell@@ -41,6 +47,9 @@ , OverloadedStrings , RankNTypes , ScopedTypeVariables+ , ExistentialQuantification+ , ConstraintKinds+ , UndecidableInstances hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall