yesod-crud-persist 0.1.1 → 0.1.2

raw patch · 4 files changed

+106/−36 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Yesod/Crud.hs +66/−30
• src/Yesod/Crud/Internal.hs +37/−0
• src/Yesod/Crud/Simple.hs +1/−5
• yesod-crud-persist.cabal +2/−1

@@ -2,18 +2,15 @@  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+ data Crud master a = Crud   { _chAdd    :: HandlerT (Crud master a) (HandlerT master IO) Html   , _chIndex  :: HandlerT (Crud master a) (HandlerT master IO) Html@@ -57,32 +54,71 @@ 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+    <|> (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")++ 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))++-- 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+  }++type HierarchyCrud master a = ChildCrud master (Maybe (Key a)) a++-- 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++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,[])++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)++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))++ 

@@ -1,5 +1,42 @@ module Yesod.Crud.Internal where +import Control.Monad.Trans.State (StateT, evalStateT, put, get)+import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)+import Data.Functor.Identity+import Control.Monad+import Yesod.Core+import Control.Applicative+import Data.Text (Text)++runSM :: [Text] -> StateT [Text] (MaybeT Identity) a -> Maybe a+runSM xs a = runIdentity $ runMaybeT $ evalStateT (a <* forceEmpty) xs++consumeMatchingText :: Text -> StateT [Text] (MaybeT Identity) ()+consumeMatchingText t = do+  p <- attemptTakeNextPiece+  guard $ p == t++consumeKey :: PathPiece k => StateT [Text] (MaybeT Identity) k+consumeKey = do+  t <- attemptTakeNextPiece+  case fromPathPiece t of+    Nothing -> mzero+    Just a  -> return a++attemptTakeNextPiece :: StateT [b] (MaybeT Identity) b+attemptTakeNextPiece = do+  s <- get+  case s of+    (a:as) -> put as >> return a+    [] -> mzero++forceEmpty :: StateT [Text] (MaybeT Identity) ()+forceEmpty = do+  s <- get+  case s of+    [] -> return ()+    _  -> mzero+ -- import ClassyPrelude.Yesod -- import Yesod.Core -- import Yesod.Core.Types

@@ -1,18 +1,14 @@ 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 Control.Lens hiding (index)  import Yesod.Core import Yesod.Form import Yesod.Persist import Data.Text (Text)-import Database.Persist hiding (get)  import Yesod.Crud 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                yesod-crud-persist-version:             0.1.1+version:             0.1.2 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@@ -43,3 +43,4 @@                      , ScopedTypeVariables   hs-source-dirs:      src   default-language:    Haskell2010+  ghc-options:       -Wall