diff --git a/Yesod/Contrib.hs b/Yesod/Contrib.hs new file mode 100644 index 00000000..bfbca604 --- /dev/null +++ b/Yesod/Contrib.hs @@ -0,0 +1,9 @@ +module Yesod.Contrib + ( module Yesod.Contrib.Formable + , module Yesod.Contrib.Crud + , module Yesod.Contrib.Persist + ) where + +import Yesod.Contrib.Formable +import Yesod.Contrib.Crud +import Yesod.Contrib.Persist diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs new file mode 100644 index 00000000..2d1cb1dd --- /dev/null +++ b/Yesod/Contrib/Crud.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +module Yesod.Contrib.Crud where + +import Yesod hiding (Form) +import Database.Persist +import Control.Applicative.Error +import Yesod.Contrib.Formable +import Yesod.Contrib.Persist +import Text.Formlets +import Control.Arrow (second) +import Data.Monoid (mempty) + +runForm :: Form xml (GHandler sub y) a -> GHandler sub y (Failing a, xml) +runForm f = do + req <- getRequest + (pp, _) <- liftIO $ reqRequestBody req + let env = map (second Left) pp + let (a, b, _) = runFormState env f + a' <- a + return (a', b) + +class Formable a => Item a where + itemTitle :: a -> String + +data Crud master item = Crud + { crudSelect :: GHandler (Crud master item) master [(Key item, item)] + , crudReplace :: Key item -> item -> GHandler (Crud master item) master () + , crudInsert :: item -> GHandler (Crud master item) master (Key item) + , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item) + , crudDelete :: Key item -> GHandler (Crud master item) master () + } + +mkYesodSub "Crud master item" + [ ("master", [''Yesod]) + , ("item", [''Item]) + , ("Key item", [''SinglePiece]) + ] [$parseRoutes| +/ CrudListR GET +/add CrudAddR GET POST +/edit/#String CrudEditR GET POST +/delete/#String CrudDeleteR GET POST +|] + +getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) + => GHandler (Crud master item) master RepHtml +getCrudListR = do + items <- getYesodSub >>= crudSelect + toMaster <- getRouteToMaster + applyLayout "Items" mempty [$hamlet| +%h1 Items +%ul + $forall items item + %li + %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ + $cs.itemTitle.snd.item$ +%p + %a!href=@toMaster.CrudAddR@ Add new item +|] + +getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) + => GHandler (Crud master item) master RepHtml +getCrudAddR = crudHelper + "Add new" + (Nothing :: Maybe (Key item, item)) + False + +postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) + => GHandler (Crud master item) master RepHtml +postCrudAddR = crudHelper + "Add new" + (Nothing :: Maybe (Key item, item)) + True + +getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +getCrudEditR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + item <- crudGet crud itemId >>= maybe notFound return + crudHelper + "Edit item" + (Just (itemId, item)) + False + +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +postCrudEditR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + item <- crudGet crud itemId >>= maybe notFound return + crudHelper + "Edit item" + (Just (itemId, item)) + False + +getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +getCrudDeleteR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + item <- crudGet crud itemId >>= maybe notFound return + toMaster <- getRouteToMaster + applyLayout "Confirm delete" mempty [$hamlet| +%form!method=post!action=@toMaster.CrudDeleteR.s@ + %h1 Really delete? + %p + %input!type=submit!value=Yes + \ + %a!href=@toMaster.CrudListR@ No +|] + +postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +postCrudDeleteR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + toMaster <- getRouteToMaster + crudDelete crud itemId + redirect RedirectTemporary $ toMaster CrudListR + +itemReadId :: SinglePiece x => String -> Maybe x +itemReadId = either (const Nothing) Just . fromSinglePiece + +crudHelper + :: (Item a, Yesod master, SinglePiece (Key a)) + => String -> Maybe (Key a, a) -> Bool + -> GHandler (Crud master a) master RepHtml +crudHelper title me isPost = do + crud <- getYesodSub + (errs, form) <- runForm $ formable $ fmap snd me + toMaster <- getRouteToMaster + errs' <- case (isPost, errs) of + (True, Success a) -> do + eid <- case me of + Just (eid, _) -> do + crudReplace crud eid a + return eid + Nothing -> crudInsert crud a + redirect RedirectTemporary $ toMaster $ CrudEditR + $ toSinglePiece eid + (True, Failure e) -> return $ Just e + (False, _) -> return Nothing + applyLayout title mempty [$hamlet| +%p + %a!href=@toMaster.CrudListR@ Return to list +%h1 $cs.title$ +$maybe errs' es + %ul + $forall es e + %li $cs.e$ +%form!method=post + %table + ^form^ + %tr + %td!colspan=2 + %input!type=submit + $maybe me e + \ + %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete +|] + +defaultCrud :: (Persist i (YesodDB a (GHandler (Crud a i) a)), YesodPersist a) + => a -> Crud a i +defaultCrud = const $ Crud + { crudSelect = runDB $ select [] [] + , crudReplace = \a -> runDB . replace a + , crudInsert = runDB . insert + , crudGet = runDB . get + , crudDelete = runDB . delete + } diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs new file mode 100644 index 00000000..5e2f0264 --- /dev/null +++ b/Yesod/Contrib/Formable.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Contrib.Formable where + +import Text.Formlets +import Text.Hamlet +import Text.Hamlet.Monad (htmlContentToByteString) +import Data.Time (Day) +import Control.Applicative +import Control.Applicative.Error +import Web.Routes.Quasi (SinglePiece) +import Database.Persist (Persistable) +import Data.Char (isAlphaNum) +import Language.Haskell.TH.Syntax +import Database.Persist (Table (..)) +import Database.Persist.Helper (upperFirst) +import Data.Convertible.Text (cs) + +class Formable a where + formable :: (Functor m, Applicative m, Monad m) + => Formlet (Hamlet url) m a + +class Fieldable a where + fieldable :: (Functor m, Applicative m, Monad m) + => String -> Formlet (Hamlet url) m a + +pack' :: String -> HtmlContent +pack' = Unencoded . cs + +instance Fieldable [Char] where + fieldable label = input' go + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %input!type=text!name=$pack'.name$!value=$pack'.val$ +|] + +instance Fieldable HtmlContent where + fieldable label = + fmap (Encoded . cs) + . input' go + . fmap (cs . htmlContentToByteString) + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %textarea!name=$pack'.name$ + $pack'.val$ +|] + +instance Fieldable Day where + fieldable label x = input' go (fmap show x) `check` asDay + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %input!type=date!name=$pack'.name$!value=$pack'.val$ +|] + asDay s = maybeRead' s "Invalid day" + +newtype Slug = Slug { unSlug :: String } + deriving (Read, Eq, Show, SinglePiece, Persistable) + +instance Fieldable Slug where + fieldable label x = input' go (fmap unSlug x) `check` asSlug + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %input!type=text!name=$pack'.name$!value=$pack'.val$ +|] + asSlug [] = Failure ["Slug must be non-empty"] + asSlug x' + | all (\c -> c `elem` "-_" || isAlphaNum c) x' = + Success $ Slug x' + | otherwise = Failure ["Slug must be alphanumeric, - and _"] + +share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] +share2 f g a = do + f' <- f a + g' <- g a + return $ f' ++ g' + +deriveFormable :: [Table] -> Q [Dec] +deriveFormable = mapM derive + where + derive :: Table -> Q Dec + derive t = do + let cols = map (upperFirst . fst) $ tableColumns t + ap <- [|(<*>)|] + just <- [|pure|] + nothing <- [|Nothing|] + let just' = just `AppE` ConE (mkName $ tableName t) + let c1 = Clause [ConP (mkName "Nothing") []] + (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) + [] + xs <- mapM (const $ newName "x") cols + let xs' = map (AppE just . VarE) xs + let c2 = Clause [ConP (mkName "Just") [ConP (mkName $ tableName t) + $ map VarP xs]] + (NormalB $ go ap just' $ zip cols xs') + [] + return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t)) + [FunD (mkName "formable") [c1, c2]] + go ap just' = foldl (ap' ap) just' . map go' + go' (label, ex) = VarE (mkName "fieldable") `AppE` LitE (StringL label) `AppE` ex + ap' ap x y = InfixE (Just x) ap (Just y) diff --git a/Yesod/Contrib/Persist.hs b/Yesod/Contrib/Persist.hs new file mode 100644 index 00000000..a009ff5a --- /dev/null +++ b/Yesod/Contrib/Persist.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +module Yesod.Contrib.Persist where + +import Yesod + +class YesodPersist y where + type YesodDB y :: (* -> *) -> * -> * + runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 0cef2369..72f628ab 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -138,7 +138,7 @@ maybeCreds = do (y, _):_ -> Just y _ -> Nothing -mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| +mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET diff --git a/yesod.cabal b/yesod.cabal index c164a0ec..d475db1b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -50,7 +50,10 @@ library random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, - old-locale >= 1.0.0.2 && < 1.1 + old-locale >= 1.0.0.2 && < 1.1, + formlets >= 0.7.1 && < 0.8, + applicative-extras >= 0.1.6 && < 0.2, + persistent >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch @@ -65,6 +68,10 @@ library Yesod.Helpers.Auth Yesod.Helpers.Sitemap Yesod.Helpers.Static + Yesod.Contrib + Yesod.Contrib.Crud + Yesod.Contrib.Formable + Yesod.Contrib.Persist ghc-options: -Wall executable runtests