yesod-crud (empty) → 0.1.1
raw patch · 7 files changed
+869/−0 lines, 7 filesdep +basedep +classy-preludedep +containerssetup-changed
Dependencies added: base, classy-prelude, containers, monad-control, persistent, random, stm, uuid, yesod-core, yesod-form, yesod-persistent
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Yesod/Contrib/League/Crud.hs +644/−0
- Yesod/Contrib/League/Crud/Persist.hs +62/−0
- Yesod/Contrib/League/Crud/Resources.hs +24/−0
- Yesod/Contrib/League/Crud/TVarMap.hs +56/−0
- yesod-crud.cabal +51/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Christopher League++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Christopher League nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/Contrib/League/Crud.hs view
@@ -0,0 +1,644 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}+{-|+Module: Yesod.Contrib.League.Crud+Description: Generic administrative CRUD operations as a Yesod subsite+Copyright: ©2015 Christopher League+Maintainer: league@contrapunctus.net++This package helps you build administrative CRUD operations (Create, Retrieve,+Update, Delete) into your web site, as Yesod subsites. There is a demo site in+the @example@ directory in the distribution.++To begin, add subsites to your @routes@ file, like these:++> /users UserCrudR CrudSubsite-UserCrud mkUserCrud+> /pubs/#UserId PubCrudR CrudSubsite-PubCrud mkPubCrud++Now, in your Foundation module, you must define the subsite foundation types+and functions. Here we have one foundation type that is nullary, and another+that carries a piece of data.++> data UserCrud = UserCrud+> mkUserCrud :: a -> CrudSubsite UserCrud+> mkUserCrud _ = CrudSubsite UserCrud+>+> data PubCrud = PubCrud UserId+> mkPubCrud :: a -> UserId -> CrudSubsite PubCrud+> mkPubCrud _ = CrudSubsite . PubCrud++Next, define the type families on which these will operate. The simplest case+is that 'ObjId' is a Persistent database 'Key' and 'Obj' is one of your model+types, but yesod-crud supports other types and non-Persistent databases too.++> instance CrudTypes UserCrud where+> type Site UserCrud = App+> type ObjId UserCrud = UserId+> type Obj UserCrud = User+>+> instance CrudTypes PubCrud where+> type Site PubCrud = App+> type ObjId PubCrud = PublicationId+> type Obj PubCrud = Publication++The above generally must go within the Foundation.hs of a scaffolded site,+because it relies on the @App@ type, and is in turn used in the routes file.+The remaining CRUD operations can be defined elsewhere and then imported into+Application.hs for the dispatcher to access.++> instance RenderMessage (CrudSubsite UserCrud) CrudMessage where+> renderMessage _ _ CrudMsgEntity = "User"+> renderMessage _ _ CrudMsgEntities = "Users"+> renderMessage _ _ m = defaultCrudMessage m+>+> instance Crud UserCrud where+> crudDB = return crudPersistDefaults+> crudShow = return . userIdent+> crudEq u v = return $ u == v+> crudMakeForm uOpt =+> return $ renderDivs $ User+> <$> areq textField "User name" (userIdent <$> uOpt)+> <*> aopt passwordField "Password" (userPassword <$> uOpt)++The minimal definition above will provide pages to list users, add a new user,+update existing users, and delete users (with a confirmation step). Various+aspects of the look and functionality can be overridden, and the CRUD widgets+can be mixed and matched on other pages too.++Comments and critiques are welcome. Please use the /Issues/ feature at+<https://github.com/league/yesod-crud>++-}+module Yesod.Contrib.League.Crud+ ( -- *Types+ CrudTypes(..)+ , CrudSubsite(..)+ , CrudHandler+ , SiteHandler+ , CrudWidget+ , CrudForm+ -- *Database operations+ , Ent+ , CrudDB(..)+ -- *CRUD operations and handlers+ , Crud(..)+ -- *The custom monad+ , CrudM+ , getCrud+ , runCrudSubsite+ , runCrudSite+ -- *Messages+ , CrudMessage(..)+ , defaultCrudMessage+ , defaultCrudAlertMessage+ , getMessenger+ -- *Subsite routes+ , Route(..)+ , getRouter+ ) where++import ClassyPrelude+import Control.Monad.Trans.Control+import Data.Either (isRight)+import Yesod.Contrib.League.Crud.Resources+import Yesod.Core+import Yesod.Form+++----------------------------------------[ TYPES++-- |Define the types used by your CRUD subsite.+class ( Eq (ObjId sub)+ , PathPiece (ObjId sub)+ ) => CrudTypes sub where++ -- |The site's foundation type+ type Site sub :: *++ -- |The type of primary keys to your objects+ type ObjId sub :: *++ -- |The type of the objects themselves+ type Obj sub :: *++-- |The foundation type for a CRUD subsite, wrapped around your own type /sub/+-- that determines the entity and carries any contextual data from the route.+newtype CrudSubsite sub = CrudSubsite { unCrud :: sub }++-- |The type of a subsite handler.+type CrudHandler sub = HandlerT (CrudSubsite sub) (SiteHandler sub)++-- |The type of the (parent) site handler.+type SiteHandler sub = HandlerT (Site sub) IO++-- |Widgets are relative to the parent site, not the subsite. This makes it a+-- little more convenient to use messages and routes from the parent.+type CrudWidget sub = WidgetT (Site sub) IO ()++-- |Forms are also defined relative to the parent site.+type CrudForm sub =+ Html -> MForm (SiteHandler sub) (FormResult (Obj sub), CrudWidget sub)+++----------------------------------------[ DATABASE OPS++-- |Like the Persistent 'Entity' type, but just a simple pair.+type Ent sub = (ObjId sub, Obj sub)++-- |The required database operations are packaged into this record type. This+-- makes it straightforward to inherit the operations wholesale into different+-- CRUD subsites (whether you are using Persistent or another mechanism), but+-- they can still be overridden by the similarly-named methods in the 'Crud'+-- class.+data CrudDB sub =+ CrudDB+ { crudSelect' :: CrudM sub [Ent sub]+ , crudInsert' :: Obj sub -> CrudM sub (ObjId sub)+ , crudGet' :: ObjId sub -> CrudM sub (Maybe (Obj sub))+ , crudReplace' :: ObjId sub -> Obj sub -> CrudM sub ()+ , crudDelete' :: ObjId sub -> CrudM sub ()+ }+++----------------------------------------[ HANDLERS AND MAIN CLASS++-- |All the necessary CRUD handlers and operations are defined in this class,+-- and can be overridden as necessary for each CRUD subsite.+class ( CrudTypes sub+ , Yesod (Site sub)+ , RenderMessage (Site sub) FormMessage+ , RenderMessage (CrudSubsite sub) CrudMessage+ ) => Crud sub where++ -- |Returns a record of database operations, for use by the next several+ -- methods. You can inherit operations wholesale by defining this method,+ -- and then override others. (If you override all the other DB methods, then+ -- this one should never be used.)+ crudDB :: CrudM sub (CrudDB sub)++ -- |Retrieve a set of entities from the database, paired with their 'ObjId'+ -- keys.+ crudSelect :: CrudM sub [Ent sub]+ crudSelect = crudDB >>= crudSelect'++ -- |Insert a new object into the database, returning its key.+ crudInsert :: Obj sub -> CrudM sub (ObjId sub)+ crudInsert obj = crudDB >>= flip crudInsert' obj++ -- |Retrieve an object with the given key.+ crudGet :: ObjId sub -> CrudM sub (Maybe (Obj sub))+ crudGet k = crudDB >>= flip crudGet' k++ -- |Replace the object at the given key with a modified one.+ crudReplace :: ObjId sub -> Obj sub -> CrudM sub ()+ crudReplace k obj = do+ db <- crudDB+ crudReplace' db k obj++ -- |Remove the object with the given key.+ crudDelete :: ObjId sub -> CrudM sub ()+ crudDelete k = crudDB >>= flip crudDelete' k++ -- |Produce a small chunk of text to describe the given object. This is used+ -- in the default 'crudListWidget', and various other places that name the+ -- object, such as the alert message "Created raspberry swirl donut." We+ -- don't require that object types implement 'Show', but if yours does this+ -- could be as simple as:+ --+ -- @+ -- crudShow = return . tshow+ -- @+ crudShow :: Obj sub -> CrudM sub Text++ -- |This is a variant of 'crudShow' that allows HTML, not just text. It is+ -- used only in 'crudListWidget', and by default it just uses 'crudShow'.+ -- Override it if you're using the default 'crudListWidget' but you want+ -- markup in your object descriptions.+ crudShowHtml :: Obj sub -> CrudM sub Html+ crudShowHtml = fmap toHtml . crudShow++ -- |When an update form is submitted, we check (in 'postCrudUpdateR') whether+ -- any changes were made before sending it to the database. If you'd like to+ -- update it regardless, return False. Be careful with forms that fill in a+ -- "last updated" field, because it should be ignored in determining+ -- equality. To use an 'Eq' instance:+ --+ -- @+ -- crudEq u v = return $ u == v+ -- @+ crudEq :: Obj sub -> Obj sub -> CrudM sub Bool++ -- |Produce a form to create or update an object.+ crudMakeForm+ :: Maybe (Obj sub) -- ^The object to update, or Nothing if creating+ -> CrudM sub (CrudForm sub)++ -- |After creating, updating, or deleting, what page should we transition to?+ -- The default implementation returns to the list page @CrudListR@. If you+ -- have a "view" page outside of the CRUD subsite, you could go there, based+ -- on the 'ObjId' parameter. (The result is a global site route, not limited+ -- to the subsite. Use 'getRouter' to translate local CRUD routes.)+ crudNextPage+ :: Maybe (ObjId sub) -- ^The object that was saved, or Nothing if deleted+ -> CrudM sub (Route (Site sub))++ crudNextPage _ = getRouter <*> pure CrudListR++ -- |This method sets an alert/flash message to appear at the top of the next+ -- page. By default, it uses 'defaultCrudAlertMessage' and 'setMessage'.+ -- Override it if you have a different messaging system. The result parameter+ -- will be 'Right' if the current page completed successfully. It contains+ -- the object, even for objects that were deleted.+ crudAlert+ :: Route (CrudSubsite sub) -- ^The page that we just completed+ -> Either SomeException (Obj sub) -- ^The result of that operation+ -> CrudM sub ()++ crudAlert route response =+ setMessage =<< defaultCrudAlertMessage route response++ -- |Creates a list widget, not including its title. The default+ -- implementation uses an ordered list, the 'crudShowHtml' description, and+ -- simple text hyperlinks to update, delete, and create a new object.+ -- Override it to substitute a table or icons. This widget should /not/+ -- include a title, which will be added by 'getCrudListR'. (But you can embed+ -- a list widget in any other handler too.)+ crudListWidget :: CrudM sub (CrudWidget sub)+ crudListWidget = do+ mr <- getMessenger+ r2p <- getRouter+ objects <- crudSelect+ let kv (objId, obj) = (objId,) <$> crudShowHtml obj+ pairs <- mapM kv objects+ return+ [whamlet|+ $if length pairs == 0+ <p>#{mr CrudMsgNoEntities}+ $else+ <ol>+ $forall (k,s) <- pairs+ <li>+ #{s}+ <a href=@{r2p $ CrudUpdateR k}>#{mr CrudMsgLinkUpdate}+ <a href=@{r2p $ CrudDeleteR k}>#{mr CrudMsgLinkDelete}+ <p>+ <a href=@{r2p CrudCreateR}>#{mr CrudMsgLinkCreate}+ |]++ -- |Creates a widget that wraps a rendered form in a @<form>@ tag and adds+ -- the submit button. Override it to customize the tag or button.+ crudFormWidget+ :: Route (CrudSubsite sub)+ -> (CrudWidget sub, Enctype)+ -> CrudM sub (CrudWidget sub)++ crudFormWidget action (w,enc) = do+ mr <- getMessenger+ r2p <- getRouter+ return+ [whamlet|+ <form method=post action=@{r2p action} enctype=#{enc}>+ ^{w}+ <input type=submit value=#{mr CrudMsgButtonSubmit}>+ |]++ -- |Creates a widget containing the object creation form. You can embed this+ -- in the list widget (replacing the text link) or in any other handler. All+ -- the real work is done by 'crudMakeForm', 'generateFormPost', and+ -- 'crudFormWidget', so there's probably no need to override this method+ -- itself.+ crudCreateWidget :: CrudM sub (CrudWidget sub)+ crudCreateWidget = do+ form <- crudMakeForm Nothing+ widgetEnc <- liftHandlerT $ generateFormPost form+ crudFormWidget CrudCreateR widgetEnc++ -- |Creates a widget to confirm deletion of an object. Override this if you+ -- want to have a more sophisticated confirmation warning (such as showing+ -- what other entities would be affected) or to change the delete button.+ crudDeleteWidget+ :: Ent sub -> CrudM sub (CrudWidget sub)++ crudDeleteWidget ent = do+ txt <- crudShow $ snd ent+ mr <- getMessenger+ return+ [whamlet|+ <p>#{mr $ CrudMsgConfirmDelete txt}+ <input type=submit value=#{mr CrudMsgButtonDelete}>+ |]++ -- |Create a form widget using 'crudFormWidget', and then add the title and+ -- convert to HTML using 'crudLayout'. Probably no need to override this+ -- method, unless to customize the default title based on 'CrudMsgEntity'.+ crudFormLayout+ :: Route (CrudSubsite sub)+ -> (CrudWidget sub, Enctype)+ -> CrudM sub Html++ crudFormLayout action widgetEnc = do+ mr <- getMessenger+ fw <- crudFormWidget action widgetEnc+ crudLayout $ do+ setTitle . toHtml . mr . routeToTitle action $ mr CrudMsgEntity+ fw++ -- |Convert a CRUD widget to HTML. Default implementation simply uses+ -- 'defaultLayout'.+ crudLayout+ :: CrudWidget sub -> CrudM sub Html++ crudLayout = liftHandlerT . defaultLayout++ -- |Handler for @GET@ on the list route @CrudListR@, to display a list of all+ -- objects. Primarily uses 'crudListWidget' and 'crudLayout', but also sets a+ -- title based on 'CrudMsgEntities'.+ getCrudListR :: CrudHandler sub Html+ getCrudListR = runCrudSubsite $ do+ mr <- getMessenger+ lw <- crudListWidget+ crudLayout $ do+ setTitle . toHtml $ mr CrudMsgEntities+ lw++ -- |Handler for @GET@ on the creation form @CrudCreateR@, to display an empty+ -- form. Primarily uses 'crudMakeForm' and 'crudFormLayout'.+ getCrudCreateR :: CrudHandler sub Html+ getCrudCreateR = runCrudSubsite $ do+ form <- crudMakeForm Nothing+ widgetEnc <- liftHandlerT $ generateFormPost form+ crudFormLayout CrudCreateR widgetEnc++ -- |Handler for @POST@ on @CrudCreateR@, to create a new object. On success,+ -- it inserts the object and displays an alert on the next page. If the form+ -- validation fails, it displays the form again with errors. (If the database+ -- insertion itself fails, it still moves on to the next page and displays+ -- the exception as an alert.)+ postCrudCreateR :: CrudHandler sub Html+ postCrudCreateR = runCrudSubsite $ do+ form <- crudMakeForm Nothing+ ((result, w), enc) <- liftHandlerT $ runFormPost form+ case result of+ FormSuccess obj -> do+ kOpt <- try $ crudInsert obj+ case kOpt of+ Left e ->+ crudAlert CrudCreateR (Left e)+ Right objId -> do+ crudAlert CrudCreateR (Right obj)+ crudNextPage (Just objId) >>= redirect+ _ -> pure ()+ crudFormLayout CrudCreateR (w, enc)++ -- |Handler for @GET@ on @CrudDeleteR@, a deletion request. It displays the+ -- object and employs an empty Yesod form for its CSRF token.+ getCrudDeleteR :: ObjId sub -> CrudHandler sub Html+ getCrudDeleteR objId = runCrudSubsite $ do+ mr <- getMessenger+ r2p <- getRouter+ obj <- crudGet objId >>= maybe404+ (tokenW, enc) <- generateFormPost . renderDivs $ pure ()+ confirmW <- crudDeleteWidget (objId, obj)+ crudLayout $ do+ setTitle . toHtml . mr . CrudMsgTitleDelete $ mr CrudMsgEntity+ [whamlet|+ <form method=post action=@{r2p $ CrudDeleteR objId} enctype=#{enc}>+ ^{tokenW}+ ^{confirmW}+ |]++ -- |Handler for @POST@ on @CrudDeleteR@, confirming a deletion request. It+ -- displays the result as an alert on the next page.+ postCrudDeleteR :: ObjId sub -> CrudHandler sub Html+ postCrudDeleteR objId = runCrudSubsite $ do+ obj <- crudGet objId >>= maybe404+ crudDelete objId+ crudAlert (CrudDeleteR objId) (Right obj)+ crudNextPage Nothing >>= redirect++ -- |Handler for @GET@ on @CrudUpdateR@, to display a form filled out with an+ -- existing object. Most of the work is done by 'crudGet', 'crudMakeForm',+ -- and 'crudFormLayout'.+ getCrudUpdateR :: ObjId sub -> CrudHandler sub Html+ getCrudUpdateR objId = runCrudSubsite $ do+ obj <- crudGet objId >>= maybe404+ form <- crudMakeForm (Just obj)+ widgetEnc <- liftHandlerT $ generateFormPost form+ crudFormLayout (CrudUpdateR objId) widgetEnc++ -- |Handler for @POST@ on @CrudUpdateR@, to update an object. Guards against+ -- updating an object that has not been changed, as detected by 'crudEq'. If+ -- the form validation fails, it displays the form again with errors. (If the+ -- database update itself fails, it still moves on to the next page and+ -- displays the exception as an alert.)+ postCrudUpdateR :: ObjId sub -> CrudHandler sub Html+ postCrudUpdateR objId = runCrudSubsite $ do+ obj <- crudGet objId >>= maybe404+ form <- crudMakeForm (Just obj)+ ((result, w), enc) <- liftHandlerT $ runFormPost form+ case result of+ FormSuccess newObj -> do+ eq <- crudEq obj newObj+ if eq+ then do+ crudAlert CrudListR (Right obj)+ crudNextPage (Just objId) >>= redirect+ else do+ unitOrExn <- try $ crudReplace objId newObj+ crudAlert (CrudUpdateR objId) (const newObj <$> unitOrExn)+ when (isRight unitOrExn) $+ crudNextPage (Just objId) >>= redirect+ _ -> pure ()+ crudFormLayout (CrudUpdateR objId) (w, enc)++maybe404 :: MonadHandler m => Maybe a -> m a+maybe404 = maybe notFound return+++----------------------------------------[ CUSTOM MONAD++data CrudEnv sub =+ CrudEnv+ { envSub :: sub+ , envMesg :: CrudMessage -> Text+ , envRoute :: Route (CrudSubsite sub) -> Route (Site sub)+ }++-- |A custom monad that can run either in the site or subsite handler. It+-- carries the subsite foundation object (retrieved with 'getCrud') and+-- appropriate converters for routes ('getRouter') and messages+-- ('getMessenger').+newtype CrudM sub a =+ CrudM+ { runCrudM :: ReaderT (CrudEnv sub) (SiteHandler sub) a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadLogger,+ MonadBase IO, MonadThrow, MonadResource)++instance MonadHandler (CrudM sub) where+ type HandlerSite (CrudM sub) = Site sub+ liftHandlerT ht = CrudM (lift ht)++instance MonadBaseControl IO (CrudM sub) where+ type StM (CrudM sub) a = a+ liftBaseWith f = CrudM $ liftBaseWith $ \q -> f (q . runCrudM)+ restoreM = CrudM . restoreM++-- |Retrieve the value of the foundation type. This is needed if your CRUD+-- paths contain parameters, such as @\/customer\/31\/donut\/15\/update@. The+-- 31 is stored in the foundation, and the 15 in the subsite route.+getCrud :: CrudM sub sub+getCrud = envSub <$> CrudM ask++-- |Run a 'CrudM' action within the subsite handler.+runCrudSubsite+ :: RenderMessage (CrudSubsite sub) CrudMessage+ => CrudM sub a -- ^Action to run+ -> CrudHandler sub a++runCrudSubsite crud = do+ mr <- getMessageRender+ r2p <- getRouteToParent+ sub <- unCrud <$> getYesod+ lift $ runReaderT (runCrudM crud) $ CrudEnv sub mr r2p++-- |Run a 'CrudM' action within the global site handler. You must provide the+-- foundation value and a route translator.+runCrudSite+ :: RenderMessage (CrudSubsite sub) CrudMessage+ => sub -- ^Foundation value+ -> (Route (CrudSubsite sub) -> Route (Site sub)) -- ^Translate subsite route to parent+ -> CrudM sub a -- ^Action to run+ -> SiteHandler sub a++runCrudSite sub r2p crud = do+ langs <- reqLangs <$> getRequest+ let mr = renderMessage (CrudSubsite sub) langs+ runReaderT (runCrudM crud) $ CrudEnv sub mr r2p+++----------------------------------------[ MESSAGES++-- |All titles, links, alerts, and button labels emitted by the default+-- implementations of Crud operations are represented by constructors of this+-- type. See 'defaultCrudMessage' for basic conversion to English text. When+-- you implement 'RenderMessage' for this type, consider overriding at least+-- the first two or three constructors to customize your entity name:+--+-- @+-- instance 'RenderMessage' ('CrudSubsite' DonutCrud) CrudMessage where+-- renderMessage _ _ CrudMsgEntity = \"Donut\"+-- renderMessage _ _ CrudMsgEntities = \"Donuts\"+-- renderMessage _ _ CrudMsgNoEntities = \"Sorry, there are no more donuts.\"+-- renderMessage _ _ m = 'defaultCrudMessage' m+-- @+data CrudMessage+ = CrudMsgEntity -- ^The singular name for your entity+ | CrudMsgEntities -- ^The plural name for your entity+ | CrudMsgNoEntities -- ^Message when no entities are found+ | CrudMsgAlertCreated Text -- ^The message "Created [object]"+ | CrudMsgAlertDeleted Text -- ^The message "Deleted [object]"+ | CrudMsgAlertNoChanges Text -- ^The message "No changes to [object]"+ | CrudMsgAlertUpdated Text -- ^The message "Updated [object]"+ | CrudMsgButtonDelete -- ^The label on button to confirm delete+ | CrudMsgButtonSubmit -- ^The label on button to save/submit+ | CrudMsgConfirmDelete Text -- ^The message "Really delete [object]?"+ | CrudMsgLinkCreate -- ^The link text leading to the create page+ | CrudMsgLinkDelete -- ^The link text leading to the delete page+ | CrudMsgLinkUpdate -- ^The link text leading to the update form+ | CrudMsgTitleCreate Text -- ^The title "Create [entity]"+ | CrudMsgTitleDelete Text -- ^The title "Delete [entity]"+ | CrudMsgTitleUpdate Text -- ^The title "Update [entity]"++-- |Basic conversion of CRUD messages to English text.+defaultCrudMessage :: CrudMessage -> Text+defaultCrudMessage m = case m of+ CrudMsgEntity -> "Object"+ CrudMsgEntities -> "Objects"+ CrudMsgNoEntities -> "No objects"+ CrudMsgAlertCreated obj -> "Created " <> obj+ CrudMsgAlertDeleted obj -> "Deleted " <> obj+ CrudMsgAlertNoChanges obj -> "No changes to " <> obj+ CrudMsgAlertUpdated obj -> "Updated " <> obj+ CrudMsgButtonDelete -> "Delete"+ CrudMsgButtonSubmit -> "Save"+ CrudMsgConfirmDelete obj -> "Really delete " <> obj <> "?"+ CrudMsgLinkCreate -> "create"+ CrudMsgLinkDelete -> "delete"+ CrudMsgLinkUpdate -> "edit"+ CrudMsgTitleCreate noun -> "Create " <> noun+ CrudMsgTitleDelete noun -> "Delete " <> noun+ CrudMsgTitleUpdate noun -> "Update " <> noun++-- |Choose and render an appropriate alert message after a CRUD operation.+defaultCrudAlertMessage+ :: Crud sub+ => Route (CrudSubsite sub) -- ^Route indicating the operation+ -> Either SomeException (Obj sub) -- ^Result of the operation+ -> CrudM sub Html -- ^Returns rendered message as HTML++defaultCrudAlertMessage route result = do+ mr <- getMessenger+ case result of+ Left exn ->+ return . toHtml $ tshow exn+ Right obj ->+ toHtml . mr . routeToAlertMessage route <$> crudShow obj++routeToAlertMessage :: Route (CrudSubsite sub) -> Text -> CrudMessage+routeToAlertMessage route obj = case route of+ CrudCreateR -> CrudMsgAlertCreated obj+ (CrudUpdateR _) -> CrudMsgAlertUpdated obj+ (CrudDeleteR _) -> CrudMsgAlertDeleted obj+ CrudListR -> CrudMsgAlertNoChanges obj++routeToTitle :: Route (CrudSubsite sub) -> Text -> CrudMessage+routeToTitle route obj = case route of+ CrudCreateR -> CrudMsgTitleCreate obj+ (CrudUpdateR _) -> CrudMsgTitleUpdate obj+ (CrudDeleteR _) -> CrudMsgTitleDelete obj+ CrudListR -> CrudMsgEntities++-- |Retrieve the message translator and renderer in the CRUD monad. Uses+-- 'getMessageRender' behind the scenes, which calls your 'RenderMessage'+-- instance with the appropriate language headers.+getMessenger :: CrudM sub (CrudMessage -> Text)+getMessenger = envMesg <$> CrudM ask+++----------------------------------------[ SUBSITE ROUTES++-- We are implementing 'RenderRoute' and 'ParseRoute' manually, so that we can+-- specify the appropriate contexts. These definitions must match the+-- 'parseRoutes' in Crud/Resources.hs!++instance CrudTypes sub => RenderRoute (CrudSubsite sub) where+ data Route (CrudSubsite sub)+ = CrudListR+ | CrudCreateR+ | CrudUpdateR (ObjId sub)+ | CrudDeleteR (ObjId sub)++ renderRoute CrudListR = ([], [])+ renderRoute CrudCreateR = (["create"], [])+ renderRoute (CrudUpdateR k) = (["update", toPathPiece k], [])+ renderRoute (CrudDeleteR k) = (["delete", toPathPiece k], [])++deriving instance Eq (ObjId sub) => Eq (Route (CrudSubsite sub))+deriving instance Read (ObjId sub) => Read (Route (CrudSubsite sub))+deriving instance Show (ObjId sub) => Show (Route (CrudSubsite sub))++instance CrudTypes sub => ParseRoute (CrudSubsite sub) where+ parseRoute ([ ], _) = Just CrudListR+ parseRoute (["create" ], _) = Just CrudCreateR+ parseRoute (["update", k], _) = CrudUpdateR <$> fromPathPiece k+ parseRoute (["delete", k], _) = CrudDeleteR <$> fromPathPiece k+ parseRoute _ = Nothing++instance (Crud sub, Site sub ~ site)+ => YesodSubDispatch (CrudSubsite sub) (HandlerT site IO) where+ yesodSubDispatch = $(mkYesodSubDispatch resourcesCrudSubsite)++-- |Retrieve a child-to-parent route translator in the CRUD monad. Uses+-- 'getRouteToParent' behind the scenes, but it adapts based on whether we're+-- being run in the site handler or a subsite handler.+getRouter :: CrudM sub (Route (CrudSubsite sub) -> Route (Site sub))+getRouter = envRoute <$> CrudM ask
+ Yesod/Contrib/League/Crud/Persist.hs view
@@ -0,0 +1,62 @@+{-|+Module: Yesod.Contrib.League.Crud.Persist+Description: Representing CRUD entities using Persistent+Copyright: ©2015 Christopher League+Maintainer: league@contrapunctus.net++This module provides default database operations using 'Database.Persist'.+Start out by setting @crudDB = return crudPersistDefaults@ and then you can+override any operations within your 'Crud' instance.+-}+module Yesod.Contrib.League.Crud.Persist+ ( crudPersistDefaults+ , crudRunDB+ , crudSelectList+ , crudEntPair+ ) where++import ClassyPrelude+import Database.Persist+import Yesod.Contrib.League.Crud+import Yesod.Core+import Yesod.Persist++type CrudPersist sub =+ ( YesodPersist (Site sub)+ , PersistEntity (Obj sub)+ , PersistEntityBackend (Obj sub) ~ YesodPersistBackend (Site sub)+ , PersistQuery (YesodPersistBackend (Site sub))+ , ObjId sub ~ Key (Obj sub)+ )++-- |Run a database query within the 'CrudM' monad.+crudRunDB :: CrudPersist sub => YesodDB (Site sub) a -> CrudM sub a+crudRunDB = liftHandlerT . runDB++-- |Helper function to convert a Persist 'Entity' into a plain pair.+crudEntPair :: Entity t -> (Key t, t)+crudEntPair (Entity k v) = (k, v)++-- |Run a 'selectList' on the CRUD type, using the given filters and options.+-- Return the entities as a plain pair of 'ObjId' and 'Obj'.+crudSelectList+ :: CrudPersist sub+ => [Filter (Obj sub)]+ -> [SelectOpt (Obj sub)]+ -> CrudM sub [Ent sub]++crudSelectList filters opts =+ crudRunDB $ map crudEntPair <$> selectList filters opts++-- |Retrieve a record of database operations that use 'Database.Persist'. By+-- default, the select is limited to returning 1000 entities, so we don't end+-- up retrieving entire large tables.+crudPersistDefaults :: CrudPersist sub => CrudDB sub+crudPersistDefaults =+ CrudDB+ { crudSelect' = crudSelectList [] [LimitTo 1000]+ , crudInsert' = crudRunDB . insert+ , crudGet' = crudRunDB . get+ , crudReplace' = \k -> crudRunDB . replace k+ , crudDelete' = crudRunDB . delete+ }
+ Yesod/Contrib/League/Crud/Resources.hs view
@@ -0,0 +1,24 @@+{-|+Module: Yesod.Contrib.League.Crud.Resources+Description: (Internal) Resource tree for generating dispatcher+Copyright: ©2015 Christopher League+Maintainer: league@contrapunctus.net+-}+module Yesod.Contrib.League.Crud.Resources+ ( resourcesCrudSubsite+ ) where++import ClassyPrelude+import Yesod.Core.Dispatch+import Yesod.Routes.TH.Types++-- |Resource tree. We implement ParseRoute and RenderRoute manually in Crud.hs,+-- so this much match the definitions there.+resourcesCrudSubsite :: [ResourceTree String]+resourcesCrudSubsite =+ [parseRoutes|+ / CrudListR GET+ /create CrudCreateR GET POST+ /update/#ObjId-sub CrudUpdateR GET POST+ /delete/#ObjId-sub CrudDeleteR GET POST+ |]
+ Yesod/Contrib/League/Crud/TVarMap.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}+{-|+Module: Yesod.Contrib.League.Crud.TVarMap+Description: Representing CRUD entities in memory+Copyright: ©2015 Christopher League+Maintainer: league@contrapunctus.net++This is a proof of concept for implementing CRUD operations that are not based+on Database.Persist. It uses a 'TVar' and a 'Map' from 'UUID' keys to the CRUD+entity.+-}+module Yesod.Contrib.League.Crud.TVarMap+ ( CrudTVarKey+ , CrudTVarMap+ , crudTVarMapDefaults+ ) where++import ClassyPrelude+import qualified Data.Map as Map+import Data.UUID+import System.Random+import Yesod.Contrib.League.Crud+import Yesod.Core++-- |The key type. A wrapper for 'UUID' that implements all the necessary+-- classes, including 'PathPiece'.+newtype CrudTVarKey =+ CrudTKey { crudUUID :: UUID }+ deriving (Eq, Ord, Read, Show, Random)++instance PathPiece CrudTVarKey where+ toPathPiece = tshow . crudUUID+ fromPathPiece = fmap CrudTKey . readMay++-- |Synonym for the map type.+type CrudTVarMap sub = Map CrudTVarKey (Obj sub)++-- |Retrieve a record of database operations for using a 'CrudTVarMap'.+crudTVarMapDefaults ::+ ( ObjId sub ~ CrudTVarKey )+ => CrudM sub (TVar (CrudTVarMap sub))+ -> CrudDB sub++crudTVarMapDefaults getMap = CrudDB {..}+ where+ crudSelect' = Map.toList <$> getTV+ crudGet' k = Map.lookup k <$> getTV+ crudReplace' k = modTV . Map.insert k+ crudDelete' = modTV . Map.delete+ crudInsert' o = do+ k <- liftIO randomIO+ modTV $ Map.insert k o+ return k++ getTV = getMap >>= atomically . readTVar+ modTV g = getMap >>= atomically . flip modifyTVar g
+ yesod-crud.cabal view
@@ -0,0 +1,51 @@+-- Initial yesod-crud.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: yesod-crud+version: 0.1.1+synopsis: Generic administrative CRUD operations as a Yesod subsite+description: This package helps you build administrative CRUD+ operations (Create, Retrieve, Update, Delete) into+ your web site, as Yesod subsites. There is a demo+ site in the @example@ directory in the distribution.+license: BSD3+license-file: LICENSE+stability: alpha+author: Christopher League+maintainer: league@contrapunctus.net+copyright: (c) 2015 Christopher League+homepage: https://github.com/league/yesod-crud+category: Web+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Yesod.Contrib.League.Crud+ Yesod.Contrib.League.Crud.Persist+ Yesod.Contrib.League.Crud.TVarMap+ other-modules: Yesod.Contrib.League.Crud.Resources+ hs-source-dirs: .+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs+ default-extensions: TemplateHaskell+ ConstraintKinds+ FlexibleContexts+ FlexibleInstances+ MultiParamTypeClasses+ NoImplicitPrelude+ OverloadedStrings+ QuasiQuotes+ StandaloneDeriving+ TypeFamilies+ ViewPatterns+ build-depends: base >= 4 && < 5+ , classy-prelude >= 0.11 && < 0.12+ , containers >= 0.5 && < 0.6+ , monad-control >= 1.0 && < 1.1+ , persistent >= 2.1 && < 2.2+ , random >= 1.1 && < 1.2+ , stm >= 2.4 && < 2.5+ , uuid >= 1.3 && < 1.4+ , yesod-core >= 1.4 && < 1.5+ , yesod-form >= 1.4 && < 1.5+ , yesod-persistent >= 1.4 && < 1.5