yesod-crud-persist (empty) → 0.1.0.0
raw patch · 6 files changed
+313/−0 lines, 6 filesdep +basedep +lensdep +persistentsetup-changed
Dependencies added: base, lens, persistent, text, transformers, wai, yesod-core, yesod-form, yesod-persistent
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- src/Yesod/Crud.hs +90/−0
- src/Yesod/Crud/Internal.hs +32/−0
- src/Yesod/Crud/Simple.hs +124/−0
- yesod-crud-persist.cabal +45/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Andrew Martin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yesod/Crud.hs view
@@ -0,0 +1,90 @@+module Yesod.Crud where++import Prelude+import Control.Applicative+import Control.Monad+import Data.Maybe++import Yesod.Core+import Database.Persist(Key)+import Control.Monad.Trans.State (StateT, evalStateT, put, get)+import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)+import Data.Functor.Identity+import Data.Text (Text)+import Network.Wai (pathInfo, requestMethod)+import qualified Data.List as List++import Yesod.Crud.Internal --remove this when my PR is accepted++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+ }++-- Dispatch for the crud subsite+instance (Eq (Key a), PathPiece (Key a)) => YesodSubDispatch (Crud master a) (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+ 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+ renderRoute r = noParams $ case r of+ EditR theId -> ["edit", toPathPiece theId]+ DeleteR theId -> ["delete", toPathPiece theId]+ IndexR -> ["index"]+ AddR -> ["add"]+ where noParams xs = (xs,[])++instance (Eq (Key a), PathPiece (Key a)) => ParseRoute (Crud master a) where+ parseRoute (_, (_:_)) = Nothing+ parseRoute (xs, []) = Nothing+ <|> (run $ pure EditR <* consumeMatchingText "edit" <*> consumeKey)+ <|> (run $ pure DeleteR <* consumeMatchingText "delete" <*> consumeKey)+ <|> (run $ pure IndexR <* consumeMatchingText "index")+ <|> (run $ pure AddR <* consumeMatchingText "add")+ where + run :: StateT [Text] (MaybeT Identity) (Route (Crud master a)) -> Maybe (Route (Crud master a))+ run a = runIdentity $ runMaybeT $ evalStateT (a <* forceEmpty) xs+ consumeMatchingText t = do+ p <- attemptTakeNextPiece+ guard $ p == t+ consumeKey = do+ t <- attemptTakeNextPiece+ case fromPathPiece t of+ Nothing -> mzero+ Just a -> return a+ attemptTakeNextPiece = do+ s <- get+ case s of+ (a:as) -> put as >> return a+ [] -> mzero+ forceEmpty = do+ s <- get+ case s of+ [] -> return ()+ _ -> mzero+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))+
+ src/Yesod/Crud/Internal.hs view
@@ -0,0 +1,32 @@+module Yesod.Crud.Internal where++-- import ClassyPrelude.Yesod+import Yesod.Core+import Yesod.Core.Types+import qualified Network.Wai as W++subHelper :: Monad m + => HandlerT child (HandlerT parent m) TypedContent+ -> YesodSubRunnerEnv child parent (HandlerT parent m)+ -> Maybe (Route child)+ -> W.Application+subHelper handlert YesodSubRunnerEnv {..} route =+ ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)+ where+ base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route++stripHandlerT :: HandlerT child (HandlerT parent m) a+ -> (parent -> child)+ -> (Route child -> Route parent)+ -> Maybe (Route child)+ -> HandlerT parent m a+stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do+ let env = handlerEnv hd+ ($ hd) $ unHandlerT $ f hd+ { handlerEnv = env+ { rheSite = getSub $ rheSite env+ , rheRoute = newRoute+ , rheRender = \url params -> rheRender env (toMaster url) params+ }+ , handlerToParent = toMaster+ }
+ src/Yesod/Crud/Simple.hs view
@@ -0,0 +1,124 @@+module Yesod.Crud.Simple where++import Prelude+import Control.Applicative+import Control.Monad+import Data.Maybe+import Data.Monoid+import Control.Lens.TH+import Control.Lens++import Yesod.Core+import Yesod.Form+import Yesod.Persist+import Data.Text (Text)+import Database.Persist hiding (get)++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+ , _scDeleteForm :: WidgetT master IO () + , _scForm :: Maybe a -> Html -> MForm (HandlerT master IO) (FormResult a, WidgetT master IO ())+ , _scFormWrap :: Enctype -> Route master -> WidgetT master IO () -> WidgetT master IO ()+ }+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) ++basicSimpleCrud :: forall master a. + PathPiece (Key a) + => Yesod master+ => YesodPersist master+ => PersistEntity a+ => PersistQuery (YesodPersistBackend master)+ => PersistEntityBackend a ~ YesodPersistBackend master+ => SimpleCrud master a+basicSimpleCrud = emptySimpleCrud+ & scIndex .~ index+ & scAdd .~ lift . defaultLayout+ & scEdit .~ lift . defaultLayout+ & scDelete .~ lift . defaultLayout+ & scDeleteForm .~ [whamlet|<button type="submit">Delete|]+ & scFormWrap .~ formWrap+ where formWrap enctype route inner = [whamlet|$newline never+ <form action="@{route}" enctype="#{enctype}" method="post">+ ^{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+ <h1>Index+ <p>+ <a href="@{tp AddR}">Add+ <table>+ <thead>+ <tr>+ <th>ID+ <th>Edit+ <th>Delete+ <tbody>+ $forall (Entity theId _) <- as+ <tr>+ <td>#{toPathPiece theId}+ <td>+ <a href="@{tp (EditR theId)}">Edit+ <td>+ <a href="@{tp (DeleteR theId)}">Delete+ |]++-- defFormWrap++simpleCrudToCrudHandler :: PersistEntityBackend a ~ YesodPersistBackend master+ => PersistEntity a+ => PersistStore (YesodPersistBackend master)+ => YesodPersist master+ => RenderMessage master FormMessage+ => SimpleCrud master a -> Crud master a+simpleCrudToCrudHandler (SimpleCrud add index edit del delForm form wrap) = + Crud addH indexH editH delH+ where + indexH = index+ delH theId = do+ tp <- getRouteToParent+ lift $ do+ res <- runInputPostResult $ ireq textField "fake"+ case res of+ FormSuccess _ -> do+ runDB $ delete theId+ setMessageI ("You have deleted the resource." :: Text)+ redirect (tp IndexR)+ _ -> return ()+ del (wrap UrlEncoded (tp $ DeleteR theId) ([whamlet|<input type="hidden" value="a" name="fake">|] <> delForm))+ addH = do + tp <- getRouteToParent+ (enctype,w) <- lift $ do+ ((res,w),enctype) <- runFormPost (form Nothing)+ case res of+ FormSuccess a -> do+ runDB $ insert_ a + setMessageI ("You have created a new resource." :: Text)+ redirect (tp IndexR)+ _ -> return (enctype,w)+ add (wrap enctype (tp AddR) w)+ editH theId = do+ tp <- getRouteToParent+ (enctype,w) <- lift $ do+ old <- runDB $ get404 theId+ ((res,w),enctype) <- runFormPost (form $ Just old)+ case res of+ FormSuccess new -> do+ runDB $ replace theId new+ setMessageI ("You have updated the resource." :: Text)+ redirect (tp IndexR)+ _ -> return (enctype,w)+ edit (wrap enctype (tp $ EditR theId) w)+
+ yesod-crud-persist.cabal view
@@ -0,0 +1,45 @@+-- Initial yesod-crud-persist.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: yesod-crud-persist+version: 0.1.0.0+synopsis: Flexible CRUD subsite usable with Yesod and Persistent.+description: Flexible CRUD subsite usable with Yesod and Persistent.+homepage: google.com+license: MIT+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+-- copyright: +category: Web+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ build-depends: base >= 4.3 && < 5.0+ , yesod-core >= 1.2+ , yesod-form >= 1.2+ , yesod-persistent >= 1.2+ , persistent >= 1.2+ , lens >= 4.0+ , text + , transformers >= 0.3.0+ , wai >= 2.0+ exposed-modules: Yesod.Crud+ , Yesod.Crud.Simple+ , Yesod.Crud.Internal+ default-extensions: QuasiQuotes+ , TemplateHaskell+ , GeneralizedNewtypeDeriving+ , RecordWildCards+ , StandaloneDeriving+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , TypeFamilies+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ hs-source-dirs: src+ default-language: Haskell2010