diff --git a/src/Yesod/Crud.hs b/src/Yesod/Crud.hs --- a/src/Yesod/Crud.hs +++ b/src/Yesod/Crud.hs @@ -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 - diff --git a/src/Yesod/Crud/Internal.hs b/src/Yesod/Crud/Internal.hs deleted file mode 100644 --- a/src/Yesod/Crud/Internal.hs +++ /dev/null @@ -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 --- } diff --git a/src/Yesod/Crud/Simple.hs b/src/Yesod/Crud/Simple.hs --- a/src/Yesod/Crud/Simple.hs +++ b/src/Yesod/Crud/Simple.hs @@ -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|