diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yesod/Contrib/League/Crud.hs b/Yesod/Contrib/League/Crud.hs new file mode 100644 --- /dev/null +++ b/Yesod/Contrib/League/Crud.hs @@ -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 + + +-} +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 +

#{mr CrudMsgNoEntities} + $else +

    + $forall (k,s) <- pairs +
  1. + #{s} + #{mr CrudMsgLinkUpdate} + #{mr CrudMsgLinkDelete} +

    + #{mr CrudMsgLinkCreate} + |] + + -- |Creates a widget that wraps a rendered form in a @

    @ 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| + + ^{w} + + |] + + -- |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| +

    #{mr $ CrudMsgConfirmDelete txt} + + |] + + -- |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| + + ^{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 diff --git a/Yesod/Contrib/League/Crud/Persist.hs b/Yesod/Contrib/League/Crud/Persist.hs new file mode 100644 --- /dev/null +++ b/Yesod/Contrib/League/Crud/Persist.hs @@ -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 + } diff --git a/Yesod/Contrib/League/Crud/Resources.hs b/Yesod/Contrib/League/Crud/Resources.hs new file mode 100644 --- /dev/null +++ b/Yesod/Contrib/League/Crud/Resources.hs @@ -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 + |] diff --git a/Yesod/Contrib/League/Crud/TVarMap.hs b/Yesod/Contrib/League/Crud/TVarMap.hs new file mode 100644 --- /dev/null +++ b/Yesod/Contrib/League/Crud/TVarMap.hs @@ -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 diff --git a/yesod-crud.cabal b/yesod-crud.cabal new file mode 100644 --- /dev/null +++ b/yesod-crud.cabal @@ -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