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
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
}
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))