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
|
||||
_ -> Nothing
|
||||
|
||||
mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|
|
||||
mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes|
|
||||
/check Check GET
|
||||
/logout Logout GET
|
||||
/openid OpenIdR GET
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user