diff --git a/src/Yesod/Crud.hs b/src/Yesod/Crud.hs --- a/src/Yesod/Crud.hs +++ b/src/Yesod/Crud.hs @@ -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 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 @@ -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 @@
^{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 -

Index -

- Add - - - - - $forall (Entity theId _) <- as - - + + + $forall c <- cs + +
ID - Edit - Delete -
#{toPathPiece theId} - - Edit - - 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 +

Index +

+ Add + +

ID + Edit + Delete +
^{nameFunc c} + + Edit + + 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||] <> 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) diff --git a/src/Yesod/Crud/Simple/Generic.hs b/src/Yesod/Crud/Simple/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Crud/Simple/Generic.hs @@ -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 + diff --git a/yesod-crud-persist.cabal b/yesod-crud-persist.cabal --- a/yesod-crud-persist.cabal +++ b/yesod-crud-persist.cabal @@ -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