yesod-crud 0.1.1 → 0.1.2

raw patch · 5 files changed

+211/−16 lines, 5 filesdep +MissingHdep +safedep ~classy-preludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: MissingH, safe

Dependency ranges changed: classy-prelude

API changes (from Hackage documentation)

Files

• Yesod/Contrib/League/Crud.hs +57/−13
• Yesod/Contrib/League/Crud/Persist.hs +13/−1
• Yesod/Contrib/League/Crud/Resources.hs +1/−0
• Yesod/Contrib/League/Crud/Sort.hs +135/−0
• yesod-crud.cabal +5/−2

@@ -280,6 +280,7 @@               #{s}               <a href=@{r2p $ CrudUpdateR k}>#{mr CrudMsgLinkUpdate}               <a href=@{r2p $ CrudDeleteR k}>#{mr CrudMsgLinkDelete}+              <a href=@{r2p $ CrudViewR k}>#{mr CrudMsgLinkView}       <p>         <a href=@{r2p CrudCreateR}>#{mr CrudMsgLinkCreate}       |]@@ -312,6 +313,16 @@     widgetEnc <- liftHandlerT $ generateFormPost form     crudFormWidget CrudCreateR widgetEnc +  -- | View entity details+  crudViewWidget+    :: Ent sub -> CrudM sub (CrudWidget sub)++  crudViewWidget ent = do+    objW <- crudShowHtml $ snd ent+    return+      [whamlet|<p>^{objW}+      |]+   -- |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.@@ -352,28 +363,30 @@   -- |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 :: CrudHandler sub TypedContent   getCrudListR = runCrudSubsite $ do     mr <- getMessenger     lw <- crudListWidget-    crudLayout $ do+    res <- crudLayout $ do       setTitle . toHtml $ mr CrudMsgEntities       lw+    return $ toTypedContent res    -- |Handler for @GET@ on the creation form @CrudCreateR@, to display an empty   -- form. Primarily uses 'crudMakeForm' and 'crudFormLayout'.-  getCrudCreateR :: CrudHandler sub Html+  getCrudCreateR :: CrudHandler sub TypedContent   getCrudCreateR = runCrudSubsite $ do     form <- crudMakeForm Nothing     widgetEnc <- liftHandlerT $ generateFormPost form-    crudFormLayout CrudCreateR widgetEnc+    res <- crudFormLayout CrudCreateR widgetEnc+    return $ toTypedContent res    -- |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 :: CrudHandler sub TypedContent   postCrudCreateR = runCrudSubsite $ do     form <- crudMakeForm Nothing     ((result, w), enc) <- liftHandlerT $ runFormPost form@@ -387,28 +400,46 @@            crudAlert CrudCreateR (Right obj)            crudNextPage (Just objId) >>= redirect       _ -> pure ()-    crudFormLayout CrudCreateR (w, enc)+    res <- crudFormLayout CrudCreateR (w, enc)+    return $ toTypedContent res +  -- |Handler for @GET@ on @CrudViewR@, an object's details  request. It displays the+  -- object and employs an empty Yesod form for return.+  getCrudViewR :: ObjId sub -> CrudHandler sub TypedContent+  getCrudViewR objId = runCrudSubsite $ do+    mr <- getMessenger+    obj <- crudGet objId >>= maybe404+    objW <- crudViewWidget (objId, obj)+    r2p <- getRouter+    res <- crudLayout $ do+      setTitle . toHtml . mr . CrudMsgTitleView $ mr CrudMsgEntity+      [whamlet|+         ^{objW}+         <p><a href=@{r2p CrudListR}>#{mr CrudMsgViewLinkNext}+       |]+    return $ toTypedContent res+   -- |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 sub -> CrudHandler sub TypedContent   getCrudDeleteR objId = runCrudSubsite $ do     mr <- getMessenger     r2p <- getRouter     obj <- crudGet objId >>= maybe404     (tokenW, enc) <- generateFormPost . renderDivs $ pure ()     confirmW <- crudDeleteWidget (objId, obj)-    crudLayout $ do+    res <- crudLayout $ do       setTitle . toHtml . mr . CrudMsgTitleDelete $ mr CrudMsgEntity       [whamlet|        <form method=post action=@{r2p $ CrudDeleteR objId} enctype=#{enc}>          ^{tokenW}          ^{confirmW}        |]+    return $ toTypedContent res    -- |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 sub -> CrudHandler sub TypedContent   postCrudDeleteR objId = runCrudSubsite $ do     obj <- crudGet objId >>= maybe404     crudDelete objId@@ -418,19 +449,20 @@   -- |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 sub -> CrudHandler sub TypedContent   getCrudUpdateR objId = runCrudSubsite $ do     obj <- crudGet objId >>= maybe404     form <- crudMakeForm (Just obj)     widgetEnc <- liftHandlerT $ generateFormPost form-    crudFormLayout (CrudUpdateR objId) widgetEnc+    res <- crudFormLayout (CrudUpdateR objId) widgetEnc+    return $ toTypedContent res    -- |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 sub -> CrudHandler sub TypedContent   postCrudUpdateR objId = runCrudSubsite $ do     obj <- crudGet objId >>= maybe404     form <- crudMakeForm (Just obj)@@ -448,7 +480,8 @@             when (isRight unitOrExn) $               crudNextPage (Just objId) >>= redirect       _ -> pure ()-    crudFormLayout (CrudUpdateR objId) (w, enc)+    res <- crudFormLayout (CrudUpdateR objId) (w, enc)+    return $ toTypedContent res  maybe404 :: MonadHandler m => Maybe a -> m a maybe404 = maybe notFound return@@ -544,9 +577,12 @@   | 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+  | CrudMsgLinkView             -- ^The link text leading to the details page   | CrudMsgTitleCreate Text     -- ^The title "Create [entity]"   | CrudMsgTitleDelete Text     -- ^The title "Delete [entity]"   | CrudMsgTitleUpdate Text     -- ^The title "Update [entity]"+  | CrudMsgTitleView Text       -- ^The title "Show [entity]"+  | CrudMsgViewLinkNext         -- ^The link text to return from object details page  -- |Basic conversion of CRUD messages to English text. defaultCrudMessage :: CrudMessage -> Text@@ -563,10 +599,13 @@   CrudMsgConfirmDelete  obj  -> "Really delete " <> obj <> "?"   CrudMsgLinkCreate          -> "create"   CrudMsgLinkDelete          -> "delete"+  CrudMsgLinkView            -> "view"   CrudMsgLinkUpdate          -> "edit"   CrudMsgTitleCreate    noun -> "Create " <> noun   CrudMsgTitleDelete    noun -> "Delete " <> noun   CrudMsgTitleUpdate    noun -> "Update " <> noun+  CrudMsgTitleView      noun -> "Show " <> noun+  CrudMsgViewLinkNext        -> "Back"  -- |Choose and render an appropriate alert message after a CRUD operation. defaultCrudAlertMessage@@ -588,6 +627,7 @@   CrudCreateR     -> CrudMsgAlertCreated obj   (CrudUpdateR _) -> CrudMsgAlertUpdated obj   (CrudDeleteR _) -> CrudMsgAlertDeleted obj+  (CrudViewR _)   -> CrudMsgAlertNoChanges obj   CrudListR       -> CrudMsgAlertNoChanges obj  routeToTitle :: Route (CrudSubsite sub) -> Text -> CrudMessage@@ -595,6 +635,7 @@   CrudCreateR     -> CrudMsgTitleCreate obj   (CrudUpdateR _) -> CrudMsgTitleUpdate obj   (CrudDeleteR _) -> CrudMsgTitleDelete obj+  (CrudViewR _) -> CrudMsgTitleView obj   CrudListR       -> CrudMsgEntities  -- |Retrieve the message translator and renderer in the CRUD monad. Uses@@ -614,11 +655,13 @@   data Route (CrudSubsite sub)     = CrudListR     | CrudCreateR+    | CrudViewR (ObjId sub)     | CrudUpdateR (ObjId sub)     | CrudDeleteR (ObjId sub)    renderRoute CrudListR = ([], [])   renderRoute CrudCreateR = (["create"], [])+  renderRoute (CrudViewR k) = (["view", toPathPiece k], [])   renderRoute (CrudUpdateR k) = (["update", toPathPiece k], [])   renderRoute (CrudDeleteR k) = (["delete", toPathPiece k], []) @@ -629,6 +672,7 @@ instance CrudTypes sub => ParseRoute (CrudSubsite sub) where   parseRoute ([           ], _) = Just CrudListR   parseRoute (["create"   ], _) = Just CrudCreateR+  parseRoute (["view", k], _) = CrudViewR <$> fromPathPiece k   parseRoute (["update", k], _) = CrudUpdateR <$> fromPathPiece k   parseRoute (["delete", k], _) = CrudDeleteR <$> fromPathPiece k   parseRoute _ = Nothing

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} {-| Module: Yesod.Contrib.League.Crud.Persist Description: Representing CRUD entities using Persistent@@ -27,6 +28,7 @@   , PersistEntityBackend (Obj sub) ~ YesodPersistBackend (Site sub)   , PersistQuery (YesodPersistBackend (Site sub))   , ObjId sub ~ Key (Obj sub)+  , Crud sub   )  -- |Run a database query within the 'CrudM' monad.@@ -54,9 +56,19 @@ crudPersistDefaults :: CrudPersist sub => CrudDB sub crudPersistDefaults =   CrudDB-  { crudSelect' = crudSelectList [] [LimitTo 1000]+  { crudSelect' = crudPersistSelect   , crudInsert' = crudRunDB . insert   , crudGet' = crudRunDB . get   , crudReplace' = \k -> crudRunDB . replace k   , crudDelete' = crudRunDB . delete   }++crudPersistSelect :: CrudPersist sub => CrudM sub [Ent sub]+crudPersistSelect = crudSelectList [] []++----applySorts :: CrudPersist sub => [Sort (SortC sub) -> SelectOpt (Obj sub)+--applySorts :: forall sub. CrudPersist sub => Sorts (SortC sub) -> CrudM sub [SelectOpt (Obj sub)]+--applySorts (Sorts s) = mapM g s+--  where g :: Sort (SortC sub) -> CrudM sub (SelectOpt (Obj sub))+--        g (Sort c True) = return $ crudSelectOpts (Asc :: EntityField (Obj sub) t -> SelectOpt (Obj sub)) c+--        g (Sort c False) = return $ crudSelectOpts Desc c

@@ -19,6 +19,7 @@   [parseRoutes|   /                  CrudListR     GET   /create            CrudCreateR   GET POST+  /view/#ObjId-sub   CrudViewR     GET   /update/#ObjId-sub CrudUpdateR   GET POST   /delete/#ObjId-sub CrudDeleteR   GET POST   |]

@@ -0,0 +1,135 @@+{-# LANGUAGE Rank2Types #-}+module Yesod.Contrib.League.Crud.Sort+       ( Sort(..)+       , Sorts(..)+       , SortC+       , ToEntityField+       , cancelLink+       , cancelSort+       , getSorts+       , isSortedBy+       , sortIndicator+       , sortToSelectOpt+       , sortsQuery+       , sortsToSelectOpts+       , toggleLink+       , toggleSort+       ) where++import ClassyPrelude+import Data.String.Utils (split)+import Database.Persist+import Yesod.Contrib.League.Crud+import Yesod.Core+import Safe (toEnumMay)++data Sort k =+  Sort { sortKey :: k+       , sortAsc :: Bool+       }+  deriving (Eq, Show)++-- Assumes that Enum k produces non-negative int, so we can encode the up/down+-- flag as the sign.+instance Enum k => Enum (Sort k) where+  fromEnum (Sort k True) = fromEnum k + 1+  fromEnum (Sort k False) = - (fromEnum k + 1)+  toEnum i = Sort (toEnum (abs i - 1)) (i > 0)++instance Bounded k => Bounded (Sort k) where+  minBound = Sort maxBound False+  maxBound = Sort maxBound True++newtype Sorts k =+  Sorts { sortsList :: [Sort k] }+  deriving (Eq, Show)++type SortC k = (Eq k, Enum k, Bounded k)++type ToEntityField k f = forall a. k -> (forall t. EntityField f t -> a) -> a++getSorts :: (SortC k, Crud sub) => CrudM sub (Sorts k)+            -- TODO: can I cache this result?+getSorts = decodeSorts . maybe "" unpack <$> lookupGetParam "s"++encodeSorts :: SortC k => Sorts k -> String+encodeSorts = intercalate "." . map (show . fromEnum) . sortsList++decodeSorts :: SortC k => String -> Sorts k+decodeSorts = Sorts . catMaybes . map readEnumMay . split "."++readEnumMay :: SortC k => String -> Maybe k+readEnumMay s = readMay s >>= toEnumMay++sortToSelectOpt :: ToEntityField k f -> Sort k -> SelectOpt f+sortToSelectOpt f (Sort c True) = f c Asc+sortToSelectOpt f (Sort c False) = f c Desc++sortsToSelectOpts :: ToEntityField k f -> Sorts k -> [SelectOpt f]+sortsToSelectOpts f = map (sortToSelectOpt f) . sortsList++sortsQuery :: SortC k => Sorts k -> [(Text, Text)]+sortsQuery s =+  if null e then [] else [("s", pack e)]+  where e = encodeSorts s++toggleSort :: SortC k => k -> Bool -> Sorts k -> Sorts k+toggleSort k f s =+  case isSortedBy k s of+   Nothing  -> liftSorts (Sort k f :) $ cancelSort k s+   Just (_, asc) -> liftSorts (Sort k (not asc) :) $ cancelSort k s++sortEq :: SortC k => k -> Sort k -> Bool+sortEq k (Sort j _) = j == k++cancelSort :: SortC k => k -> Sorts k -> Sorts k+cancelSort k = liftSorts $ filter (not . sortEq k)++liftSorts :: ([Sort j] -> [Sort k]) -> Sorts j -> Sorts k+liftSorts f = Sorts . f . sortsList++isSortedBy :: SortC k => k -> Sorts k -> Maybe (Int, Bool)+isSortedBy k = loop 1 . sortsList+  where loop _ [] = Nothing+        loop i (Sort j asc : _) | j == k = Just (i, asc)+        loop i (_: s) = loop (i+1) s++toggleLink+  :: (SortC k, Crud sub)+     => k+     -> Bool+     -> Sorts k+     -> (Route (CrudSubsite sub) -> Route (Site sub))+     -> (Route (Site sub), [(Text, Text)])++toggleLink criterion defaultAscending sorts r =+  (r CrudListR, sortsQuery (toggleSort criterion defaultAscending sorts))++cancelLink+  :: (SortC k, Crud sub)+     => k+     -> Sorts k+     -> (Route (CrudSubsite sub) -> Route (Site sub))+     -> (Route (Site sub), [(Text, Text)])++cancelLink criterion sorts r =+  (r CrudListR, sortsQuery (cancelSort criterion sorts))++sortIndicator+  :: (SortC k, Crud sub)+     => k+     -> Sorts k+     -> (Route (CrudSubsite sub) -> Route (Site sub))+     -> CrudWidget sub++sortIndicator criterion sorts r =+  [whamlet|+   $maybe (i,k) <- isSortedBy criterion sorts+     <span .crud-sorts>+       $if k+         ↑+       $else+         ↓+       #{i}+       <a href=@?{cancelLink criterion sorts r}>×+   |]

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                yesod-crud-version:             0.1.1+version:             0.1.2 synopsis:            Generic administrative CRUD operations as a Yesod subsite description:         This package helps you build administrative CRUD                      operations (Create, Retrieve, Update, Delete) into@@ -22,6 +22,7 @@ library   exposed-modules:     Yesod.Contrib.League.Crud                        Yesod.Contrib.League.Crud.Persist+                       Yesod.Contrib.League.Crud.Sort                        Yesod.Contrib.League.Crud.TVarMap   other-modules:       Yesod.Contrib.League.Crud.Resources   hs-source-dirs:      .@@ -39,11 +40,13 @@                        TypeFamilies                        ViewPatterns   build-depends:       base                  >= 4    && < 5-                     , classy-prelude        >= 0.11 && < 0.12+                     , classy-prelude        >= 0.11 && < 0.13                      , containers            >= 0.5  && < 0.6+                     , MissingH              >= 1.3  && < 1.4                      , monad-control         >= 1.0  && < 1.1                      , persistent            >= 2.1  && < 2.2                      , random                >= 1.1  && < 1.2+                     , safe                  >= 0.3.9                      , stm                   >= 2.4  && < 2.5                      , uuid                  >= 1.3  && < 1.4                      , yesod-core            >= 1.4  && < 1.5