Initial inclusion of persistent support
This commit is contained in:
Michael Snoyman
parent
7262c30c74
commit
2947c3b4b6
9
Yesod/Contrib.hs
Normal file
9
Yesod/Contrib.hs
Normal file
@ -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
|
||||||
172
Yesod/Contrib/Crud.hs
Normal file
172
Yesod/Contrib/Crud.hs
Normal file
@ -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
|
||||||
|
}
|
||||||
114
Yesod/Contrib/Formable.hs
Normal file
114
Yesod/Contrib/Formable.hs
Normal file
@ -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)
|
||||||
8
Yesod/Contrib/Persist.hs
Normal file
8
Yesod/Contrib/Persist.hs
Normal file
@ -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
|
||||||
@ -138,7 +138,7 @@ maybeCreds = do
|
|||||||
(y, _):_ -> Just y
|
(y, _):_ -> Just y
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|
|
mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes|
|
||||||
/check Check GET
|
/check Check GET
|
||||||
/logout Logout GET
|
/logout Logout GET
|
||||||
/openid OpenIdR GET
|
/openid OpenIdR GET
|
||||||
|
|||||||
@ -50,7 +50,10 @@ library
|
|||||||
random >= 1.0.0.2 && < 1.1,
|
random >= 1.0.0.2 && < 1.1,
|
||||||
control-monad-attempt >= 0.3 && < 0.4,
|
control-monad-attempt >= 0.3 && < 0.4,
|
||||||
cereal >= 0.2 && < 0.3,
|
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
|
exposed-modules: Yesod
|
||||||
Yesod.Content
|
Yesod.Content
|
||||||
Yesod.Dispatch
|
Yesod.Dispatch
|
||||||
@ -65,6 +68,10 @@ library
|
|||||||
Yesod.Helpers.Auth
|
Yesod.Helpers.Auth
|
||||||
Yesod.Helpers.Sitemap
|
Yesod.Helpers.Sitemap
|
||||||
Yesod.Helpers.Static
|
Yesod.Helpers.Static
|
||||||
|
Yesod.Contrib
|
||||||
|
Yesod.Contrib.Crud
|
||||||
|
Yesod.Contrib.Formable
|
||||||
|
Yesod.Contrib.Persist
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
||||||
executable runtests
|
executable runtests
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user