yesod-crud-persist 0.2.1 → 0.3
raw patch · 9 files changed
+792/−494 lines, 9 files
Files
- src/Yesod/Crud.hs +63/−195
- src/Yesod/Crud/Internal.hs +0/−69
- src/Yesod/Crud/Simple.hs +59/−99
- src/Yesod/Crud/Simple/Generic.hs +0/−92
- src/Yesod/OldCrud.hs +259/−0
- src/Yesod/OldCrud/Internal.hs +69/−0
- src/Yesod/OldCrud/Simple.hs +211/−0
- src/Yesod/OldCrud/Simple/Generic.hs +92/−0
- yesod-crud-persist.cabal +39/−39
src/Yesod/Crud.hs view
@@ -17,220 +17,88 @@ import qualified Data.List as List import qualified Database.Esqueleto as E -import Yesod.Crud.Internal+import Yesod.OldCrud.Internal import Data.Typeable import Data.Proxy import Unsafe.Coerce (unsafeCoerce) -- 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+data CrudHandler site p c = CrudHandler+ { _chAdd :: p -> HandlerT site IO Html+ , _chIndex :: p -> HandlerT site IO Html+ , _chEdit :: Key c -> HandlerT site IO Html+ , _chDelete :: Key c -> HandlerT site IO Html+ , _chView :: Key c -> HandlerT site IO Html }-makeLenses ''Crud--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)+makeLenses ''CrudHandler --- By using this, you will trade some type safety-data SomeCrud master = forall p c. (Typeable p, Typeable c) => SomeCrud (Crud master p c)+data CrudRoute p c+ = AddR p+ | IndexR p+ | EditR (Key c)+ | DeleteR (Key c)+ | ViewR (Key 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+data EditParent = EditParentView | EditParentIndex --- 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 -> _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+handleCrud :: CrudHandler site p c -> CrudRoute p c -> HandlerT site IO Html+handleCrud (CrudHandler add index edit delete view) route = case route of+ AddR p -> add p+ IndexR p -> index p+ EditR p -> edit p+ DeleteR p -> delete p+ ViewR p -> view p -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+instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => PathMultiPiece (CrudRoute p c) where+ fromPathMultiPiece xs = Nothing+ <|> (runSM xs $ pure EditR <* consumeMatchingText "edit" <*> consumeKey)+ <|> (runSM xs $ pure DeleteR <* consumeMatchingText "delete" <*> consumeKey)+ <|> (runSM xs $ pure IndexR <* consumeMatchingText "index" <*> consumeKey)+ <|> (runSM xs $ pure AddR <* consumeMatchingText "add" <*> consumeKey)+ <|> (runSM xs $ pure ViewR <* consumeMatchingText "view" <*> consumeKey)+ toPathMultiPiece r = case r of EditR theId -> ["edit", toPathPiece theId] DeleteR theId -> ["delete", toPathPiece theId] IndexR p -> ["index", toPathPiece p] AddR p -> ["add", toPathPiece p] ViewR theId -> ["view", toPathPiece theId]- where noParams xs = (xs,[]) -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" <*> 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))--type HierarchyCrud master a = Crud master (Maybe (Key a)) a+breadcrumbsCrud :: PersistCrudEntity site c+ => EditParent+ -> (CrudRoute p c -> Route site) + -> CrudRoute p c+ -> Text+ -> (Entity c -> Text)+ -> (Key c -> YesodDB site p)+ -> (p -> YesodDB site (Maybe (Route site))) + -> HandlerT site IO (Text, Maybe (Route site))+breadcrumbsCrud editParent tp route indexName getName getParent getIndexParent = case route of+ AddR p -> return ("Add", Just $ tp $ IndexR p)+ IndexR p -> do+ indexParent <- runDB $ getIndexParent p+ return (indexName, indexParent)+ ViewR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return (getName (Entity cid c), Just $ tp $ IndexR p)+ EditR cid -> case editParent of+ EditParentView -> return ("Edit", Just $ tp $ ViewR cid)+ EditParentIndex -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return ("Edit - " <> getName (Entity cid c), Just $ tp $ IndexR p)+ DeleteR cid -> return ("Delete", Just $ tp $ ViewR cid) -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+deriving instance (Eq (Key c), Eq p) => Eq (CrudRoute p c)+deriving instance (Show (Key c), Show p) => Show (CrudRoute p c)+deriving instance (Read (Key c), Read p) => Read (CrudRoute p c) -type PersistCrudEntity master a =+type PersistCrudEntity site a = ( PathPiece (Key a) - , Yesod master- , YesodPersist master- , PersistEntity a- , PersistQuery (YesodPersistBackend master)- , PersistEntityBackend a ~ YesodPersistBackend master- )--type SqlClosure a c = - ( ClosureTablePair a c- , PersistEntityBackend a ~ SqlBackend- , PersistEntityBackend (ClosureTable a) ~ SqlBackend+ , Yesod site+ , YesodPersist site , PersistEntity a- , PersistEntity c- , PersistField (Key a)+ , PersistQuery (YesodPersistBackend site)+ , PersistEntityBackend a ~ YesodPersistBackend site )--closureDepthColAs :: forall a c. ClosureTablePair a c - => Key a -> EntityField c Int-closureDepthColAs _ = (closureDepthCol :: EntityField c Int)--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---- 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/Internal.hs
@@ -1,69 +0,0 @@-module Yesod.Crud.Internal where--import Control.Monad.Trans.State (StateT, evalStateT, put, get)-import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)-import Data.Functor.Identity-import Control.Monad-import Yesod.Core-import Control.Applicative-import Data.Text (Text)--runSM :: [Text] -> StateT [Text] (MaybeT Identity) a -> Maybe a-runSM xs a = runIdentity $ runMaybeT $ evalStateT (a <* forceEmpty) xs--consumeMatchingText :: Text -> StateT [Text] (MaybeT Identity) ()-consumeMatchingText t = do- p <- attemptTakeNextPiece- guard $ p == t--consumeKey :: PathPiece k => StateT [Text] (MaybeT Identity) k-consumeKey = do- t <- attemptTakeNextPiece- case fromPathPiece t of- Nothing -> mzero- Just a -> return a--attemptTakeNextPiece :: StateT [b] (MaybeT Identity) b-attemptTakeNextPiece = do- s <- get- case s of- (a:as) -> put as >> return a- [] -> mzero--forceEmpty :: StateT [Text] (MaybeT Identity) ()-forceEmpty = do- s <- get- case s of- [] -> return ()- _ -> mzero---- import ClassyPrelude.Yesod--- import Yesod.Core--- import Yesod.Core.Types--- import qualified Network.Wai as W--- --- subHelper :: Monad m --- => HandlerT child (HandlerT parent m) TypedContent--- -> YesodSubRunnerEnv child parent (HandlerT parent m)--- -> Maybe (Route child)--- -> W.Application--- subHelper handlert YesodSubRunnerEnv {..} route =--- ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)--- where--- base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route--- --- stripHandlerT :: HandlerT child (HandlerT parent m) a--- -> (parent -> child)--- -> (Route child -> Route parent)--- -> Maybe (Route child)--- -> HandlerT parent m a--- stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do--- let env = handlerEnv hd--- ($ hd) $ unHandlerT $ f hd--- { handlerEnv = env--- { rheSite = getSub $ rheSite env--- , rheRoute = newRoute--- , rheRender = \url params -> rheRender env (toMaster url) params--- }--- , handlerToParent = toMaster--- }
src/Yesod/Crud/Simple.hs view
@@ -15,30 +15,27 @@ import Yesod.Crud -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 :: 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+data SimpleCrud site p c = SimpleCrud+ { _scAdd :: WidgetT site IO () -> HandlerT site IO Html+ , _scIndex :: p -> HandlerT site IO Html+ , _scView :: Key c -> HandlerT site IO Html+ , _scEdit :: WidgetT site IO () -> HandlerT site IO Html+ , _scDelete :: WidgetT site IO () -> HandlerT site IO Html+ , _scDeleteForm :: WidgetT site IO () + , _scForm :: Either p c -> Html -> MForm (HandlerT site IO) (FormResult c, WidgetT site IO ())+ , _scFormWrap :: Enctype -> Route site -> WidgetT site IO () -> WidgetT site IO ()+ , _scDeleteDb :: Key c -> YesodDB site p+ , _scAddDb :: p -> c -> YesodDB site (Key c)+ , _scEditDb :: Key c -> c -> YesodDB site p+ , _scMessageWrap :: Html -> Html+ , _scEditParent :: EditParent+ , _scPromoteRoute :: CrudRoute p c -> Route site } makeLenses ''SimpleCrud -emptyParentlessSimpleCrud :: - PathPiece (Key a) - => Yesod master- => YesodPersist master- => PersistEntity a- => PersistQuery (YesodPersistBackend master)- => PersistEntityBackend a ~ YesodPersistBackend master- => SimpleCrud master () a-emptyParentlessSimpleCrud = SimpleCrud +emptyParentlessSimpleCrud :: PersistCrudEntity site c+ => (CrudRoute () c -> Route site) -> SimpleCrud site () c+emptyParentlessSimpleCrud tp = SimpleCrud (const $ return mempty) -- add (const $ return mempty) -- index (const $ return mempty) -- view@@ -49,16 +46,13 @@ delete -- default deletion, assumes no FK constraints (const insert) -- default DB add replace -- default DB edit+ id -- default message wrap+ EditParentIndex+ tp -emptyChildSimpleCrud :: - PathPiece (Key a) - => Yesod master- => YesodPersist master- => PersistEntity a- => PersistQuery (YesodPersistBackend master)- => PersistEntityBackend a ~ YesodPersistBackend master- => (Key a -> YesodDB master p) -> SimpleCrud master p a-emptyChildSimpleCrud getParent = SimpleCrud +emptyChildSimpleCrud :: PersistCrudEntity site c+ => (CrudRoute p c -> Route site) -> (Key c -> YesodDB site p) -> SimpleCrud site p c+emptyChildSimpleCrud tp getParent = SimpleCrud (const $ return mempty) -- add (const $ return mempty) -- index (const $ return mempty) -- view@@ -69,6 +63,9 @@ del -- default deletion, assumes no FK constraints (const insert) -- default DB add edit -- default DB edit+ id -- default message wrap+ EditParentIndex+ tp where del k = do p <- getParent k@@ -78,36 +75,13 @@ 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 :: PersistCrudEntity site a+ => SimpleCrud site p a -> SimpleCrud site p a applyBasicLayoutsAndForms initial = initial- & scIndex .~ basicSimpleCrudIndex (toWidget . toHtml . toPathPiece . entityKey)- & scAdd .~ lift . defaultLayout- & scEdit .~ lift . defaultLayout- & scDelete .~ lift . defaultLayout+ & scIndex .~ basicSimpleCrudIndex (_scPromoteRoute initial) (toWidget . toHtml . toPathPiece . entityKey)+ & scAdd .~ defaultLayout+ & scEdit .~ defaultLayout+ & scDelete .~ defaultLayout & scDeleteForm .~ [whamlet|<button type="submit">Delete|] & scFormWrap .~ formWrap where formWrap enctype route inner = [whamlet|$newline never@@ -116,11 +90,10 @@ |] 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+ => (CrudRoute p c -> Route site) -> (Entity c -> WidgetT site IO ()) -> p -> HandlerT site IO Html+basicSimpleCrudIndex tp nameFunc p = do+ cs <- runDB $ selectList [] []+ defaultLayout $ [whamlet|$newline never <h1>Index <p> <a href="@{tp (AddR p)}">Add@@ -140,62 +113,49 @@ <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)+basicSimpleCrud :: PersistCrudEntity site c => (CrudRoute () c -> Route site) -> SimpleCrud site () c+basicSimpleCrud tp = applyBasicLayoutsAndForms (emptyParentlessSimpleCrud tp) -basicHierarchySimpleCrud :: (PersistCrudEntity master a, SqlClosure a c)- => SimpleCrud master (Maybe (Key a)) a-basicHierarchySimpleCrud = applyBasicLayoutsAndForms emptyHierarchySimpleCrud+basicChildSimpleCrud :: PersistCrudEntity site c => (CrudRoute p c -> Route site) -> (Key c -> YesodDB site p) -> SimpleCrud site p c+basicChildSimpleCrud tp f = applyBasicLayoutsAndForms (emptyChildSimpleCrud tp f) -simpleCrudToCrud :: - PersistEntityBackend a ~ YesodPersistBackend master- => PersistEntity a- => PersistStore (YesodPersistBackend master)- => YesodPersist master- => RenderMessage master FormMessage- => 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+toCrudHandler :: (PersistCrudEntity site c, RenderMessage site FormMessage) + => SimpleCrud site p c -> CrudHandler site p c+toCrudHandler (SimpleCrud add index view edit del delForm form wrap delDb addDb editDb messageWrap editParent tp) = + CrudHandler 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- p <- runDB $ delDb theId- setMessageI ("You have deleted the resource." :: Text)- redirect (tp $ IndexR p)- _ -> return ()+ res <- runInputPostResult $ ireq textField "fake"+ case res of+ FormSuccess _ -> do+ p <- runDB $ delDb theId+ setMessage $ messageWrap "You have deleted the resource."+ redirect (tp $ IndexR p)+ _ -> return () del (wrap UrlEncoded (tp $ DeleteR theId) ([whamlet|<input type="hidden" value="a" name="fake">|] <> delForm)) addH p = do - tp <- getRouteToParent- (enctype,w) <- lift $ do+ (enctype,w) <- do ((res,w),enctype) <- runFormPost (form $ Left p) case res of FormSuccess a -> do void $ runDB $ addDb p a - setMessageI ("You have created a new resource." :: Text)+ setMessage $ messageWrap "You have created a new resource" redirect (tp $ IndexR p) _ -> return (enctype,w) add (wrap enctype (tp $ AddR p) w) editH theId = do- tp <- getRouteToParent- (enctype,w) <- lift $ do+ (enctype,w) <- do old <- runDB $ get404 theId ((res,w),enctype) <- runFormPost (form $ Right old) case res of FormSuccess new -> do p <- runDB $ editDb theId new- setMessageI ("You have updated the resource." :: Text)- redirect (tp $ IndexR p)+ setMessage $ messageWrap "You have updated the resource."+ redirect $ tp $ case editParent of+ EditParentView -> ViewR theId+ EditParentIndex -> IndexR p _ -> return (enctype,w) edit (wrap enctype (tp $ EditR theId) w)
− src/Yesod/Crud/Simple/Generic.hs
@@ -1,92 +0,0 @@-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-
+ src/Yesod/OldCrud.hs view
@@ -0,0 +1,259 @@+module Yesod.OldCrud where++import Prelude+import Control.Applicative+import Data.Maybe++import Lens.Micro.TH++import Yesod.Core+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.OldCrud.Internal+import Data.Typeable+import Data.Proxy+import Unsafe.Coerce (unsafeCoerce)++-- 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++data EditParent = EditParentView | EditParentIndex++breadcrumbsCrud' :: PersistCrudEntity master c+ => EditParent+ -> (Route (Crud master p c) -> Route master) + -> Route (Crud master p c) + -> Text+ -> (Entity c -> Text)+ -> (Key c -> YesodDB master p)+ -> (p -> YesodDB master (Maybe (Route master))) + -> HandlerT master IO (Text, Maybe (Route master))+breadcrumbsCrud' editParent tp route indexName getName getParent getIndexParent = case route of+ AddR p -> return ("Add", Just $ tp $ IndexR p)+ IndexR p -> do+ indexParent <- runDB $ getIndexParent p+ return (indexName, indexParent)+ ViewR cid -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return (getName (Entity cid c), Just $ tp $ IndexR p)+ EditR cid -> case editParent of+ EditParentView -> return ("Edit", Just $ tp $ ViewR cid)+ EditParentIndex -> do+ c <- runDB $ get404 cid+ p <- runDB $ getParent cid+ return ("Edit - " <> getName (Entity cid c), Just $ tp $ IndexR p)+ DeleteR cid -> return ("Delete", Just $ tp $ ViewR cid)++breadcrumbsCrud2 :: PersistCrudEntity master c+ => (Route (Crud master p c) -> Route master) + -> Route (Crud master p c) + -> Text+ -> (Entity c -> Text)+ -> (Key c -> YesodDB master p)+ -> (p -> YesodDB master (Maybe (Route master))) + -> HandlerT master IO (Text, Maybe (Route master))+breadcrumbsCrud2 = breadcrumbsCrud' EditParentView++breadcrumbsCrud :: + PersistCrudEntity master c+ => (Route (Crud master p c) -> Route master) + -> Route (Crud master p c) + -> Text+ -> (Entity c -> Text)+ -> (Key c -> YesodDB master p)+ -> (p -> YesodDB master (Maybe (Route master))) + -> HandlerT master IO (Text, Maybe (Route master))+breadcrumbsCrud = breadcrumbsCrud' EditParentIndex++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 -> _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 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]+ DeleteR theId -> ["delete", toPathPiece theId]+ IndexR p -> ["index", toPathPiece p]+ AddR p -> ["add", toPathPiece p]+ ViewR theId -> ["view", toPathPiece theId]+ where noParams xs = (xs,[])++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" <*> 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))++type HierarchyCrud master a = Crud master (Maybe (Key a)) a++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 PersistCrudEntity master a =+ ( PathPiece (Key a) + , Yesod master+ , YesodPersist master+ , PersistEntity a+ , PersistQuery (YesodPersistBackend master)+ , PersistEntityBackend a ~ YesodPersistBackend master+ )++type SqlClosure a c = + ( ClosureTablePair a c+ , PersistEntityBackend a ~ SqlBackend+ , PersistEntityBackend (ClosureTable a) ~ SqlBackend+ , PersistEntity a+ , PersistEntity c+ , PersistField (Key a)+ )++closureDepthColAs :: forall a c. ClosureTablePair a c + => Key a -> EntityField c Int+closureDepthColAs _ = (closureDepthCol :: EntityField c Int)++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++-- 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/OldCrud/Internal.hs view
@@ -0,0 +1,69 @@+module Yesod.OldCrud.Internal where++import Control.Monad.Trans.State (StateT, evalStateT, put, get)+import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)+import Data.Functor.Identity+import Control.Monad+import Yesod.Core+import Control.Applicative+import Data.Text (Text)++runSM :: [Text] -> StateT [Text] (MaybeT Identity) a -> Maybe a+runSM xs a = runIdentity $ runMaybeT $ evalStateT (a <* forceEmpty) xs++consumeMatchingText :: Text -> StateT [Text] (MaybeT Identity) ()+consumeMatchingText t = do+ p <- attemptTakeNextPiece+ guard $ p == t++consumeKey :: PathPiece k => StateT [Text] (MaybeT Identity) k+consumeKey = do+ t <- attemptTakeNextPiece+ case fromPathPiece t of+ Nothing -> mzero+ Just a -> return a++attemptTakeNextPiece :: StateT [b] (MaybeT Identity) b+attemptTakeNextPiece = do+ s <- get+ case s of+ (a:as) -> put as >> return a+ [] -> mzero++forceEmpty :: StateT [Text] (MaybeT Identity) ()+forceEmpty = do+ s <- get+ case s of+ [] -> return ()+ _ -> mzero++-- import ClassyPrelude.Yesod+-- import Yesod.Core+-- import Yesod.Core.Types+-- import qualified Network.Wai as W+-- +-- subHelper :: Monad m +-- => HandlerT child (HandlerT parent m) TypedContent+-- -> YesodSubRunnerEnv child parent (HandlerT parent m)+-- -> Maybe (Route child)+-- -> W.Application+-- subHelper handlert YesodSubRunnerEnv {..} route =+-- ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)+-- where+-- base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route+-- +-- stripHandlerT :: HandlerT child (HandlerT parent m) a+-- -> (parent -> child)+-- -> (Route child -> Route parent)+-- -> Maybe (Route child)+-- -> HandlerT parent m a+-- stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do+-- let env = handlerEnv hd+-- ($ hd) $ unHandlerT $ f hd+-- { handlerEnv = env+-- { rheSite = getSub $ rheSite env+-- , rheRoute = newRoute+-- , rheRender = \url params -> rheRender env (toMaster url) params+-- }+-- , handlerToParent = toMaster+-- }
+ src/Yesod/OldCrud/Simple.hs view
@@ -0,0 +1,211 @@+module Yesod.OldCrud.Simple where++import Prelude+import Data.Monoid+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.OldCrud++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 :: 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+ , _scMessageWrap :: Html -> Html+ , _scEditParent :: EditParent+ }+makeLenses ''SimpleCrud++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+ id -- default message wrap+ EditParentIndex++emptyChildSimpleCrud :: + PathPiece (Key a) + => Yesod master+ => YesodPersist master+ => PersistEntity a+ => PersistQuery (YesodPersistBackend master)+ => PersistEntityBackend a ~ YesodPersistBackend master+ => (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+ id -- default message wrap+ EditParentIndex+ 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+ id -- default message wrap+ EditParentIndex+ 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+ & scDeleteForm .~ [whamlet|<button type="submit">Delete|]+ & scFormWrap .~ formWrap+ where formWrap enctype route inner = [whamlet|$newline never+ <form action="@{route}" enctype="#{enctype}" method="post">+ ^{inner}+ |]++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 p a -> Crud master p a+simpleCrudToCrud (SimpleCrud add index view edit del delForm form wrap delDb addDb editDb messageWrap editParent) = + 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+ p <- runDB $ delDb theId+ setMessage $ messageWrap "You have deleted the resource."+ redirect (tp $ IndexR p)+ _ -> return ()+ del (wrap UrlEncoded (tp $ DeleteR theId) ([whamlet|<input type="hidden" value="a" name="fake">|] <> delForm))+ addH p = do + tp <- getRouteToParent+ (enctype,w) <- lift $ do+ ((res,w),enctype) <- runFormPost (form $ Left p)+ case res of+ FormSuccess a -> do+ void $ runDB $ addDb p a + setMessage $ messageWrap "You have created a new resource"+ redirect (tp $ IndexR p)+ _ -> return (enctype,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 $ Right old)+ case res of+ FormSuccess new -> do+ p <- runDB $ editDb theId new+ setMessage $ messageWrap "You have updated the resource."+ redirect $ tp $ case editParent of+ EditParentView -> ViewR theId+ EditParentIndex -> IndexR p+ _ -> return (enctype,w)+ edit (wrap enctype (tp $ EditR theId) w)+
+ src/Yesod/OldCrud/Simple/Generic.hs view
@@ -0,0 +1,92 @@+module Yesod.OldCrud.Simple.Generic where++import Prelude+import Yesod.OldCrud+import Yesod.OldCrud.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
@@ -1,8 +1,5 @@--- Initial yesod-crud-persist.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: yesod-crud-persist-version: 0.2.1+version: 0.3 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@@ -10,46 +7,49 @@ license-file: LICENSE author: Andrew Martin maintainer: andrew.thaddeus@gmail.com--- copyright: category: Web build-type: Simple--- extra-source-files: cabal-version: >=1.10 library- build-depends: base >= 4.3 && < 5.0- , yesod-core >= 1.4.11- , yesod-form >= 1.2- , yesod-persistent >= 1.2- , 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- , GeneralizedNewtypeDeriving- , RecordWildCards- , StandaloneDeriving- , FlexibleContexts- , FlexibleInstances- , MultiParamTypeClasses- , TypeFamilies- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , ExistentialQuantification- , ConstraintKinds- , UndecidableInstances+ build-depends: + base >= 4.3 && < 5.0+ , yesod-core >= 1.4.11+ , yesod-form >= 1.2+ , yesod-persistent >= 1.2+ , 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.OldCrud+ , Yesod.OldCrud.Simple+ , Yesod.OldCrud.Simple.Generic+ , Yesod.OldCrud.Internal+ , Yesod.Crud+ , Yesod.Crud.Simple+ default-extensions: + QuasiQuotes+ , TemplateHaskell+ , GeneralizedNewtypeDeriving+ , RecordWildCards+ , StandaloneDeriving+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , TypeFamilies+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , ExistentialQuantification+ , ConstraintKinds+ , UndecidableInstances hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall