diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/src/Yesod/Crud.hs b/src/Yesod/Crud.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Crud.hs @@ -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)) + diff --git a/src/Yesod/Crud/Internal.hs b/src/Yesod/Crud/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Crud/Internal.hs @@ -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 + } diff --git a/src/Yesod/Crud/Simple.hs b/src/Yesod/Crud/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Crud/Simple.hs @@ -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|