diff --git a/examples/usersite.hs b/examples/usersite.hs new file mode 100644 --- /dev/null +++ b/examples/usersite.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GADTs, MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, EmptyDataDecls #-} +import Yesod +import Database.Persist.Sqlite +import Yesod.VEND +import Data.Maybe +import Data.Text(Text) +import Control.Applicative + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| +User + ident Text + name Text Maybe + address Text Maybe + telephone Text Maybe + deriving Show +|] + +data VendUserTest = VendUserTest ConnectionPool + +mkYesod "VendUserTest" [parseRoutes| +/user/new UserNewR +/user/edit/#UserId UserEditR +/user/delete/#UserId UserDeleteR +/user/view/all UserViewAllR +/user/view/single/#UserId UserViewR +/ HomeR +|] + +instance Yesod VendUserTest + +instance YesodPersist VendUserTest where + type YesodPersistBackend VendUserTest = SqlPersist + + runDB action = do + VendUserTest pool <- getYesod + runSqlPool action pool +--- +data UserP = UserP +instance EntityDeep UserId where + type EntT UserId = User + type FullEntT UserId = User + type SiteEntT UserId = VendUserTest + + paramsFull _ = params UserP + +instance CRUD UserP where + type ValT UserP = User + type KeyT UserP = UserId + type SiteT UserP = VendUserTest + + newRt _ = UserNewR + editRt _ = UserEditR + deleteRt _ = UserDeleteR + viewRt _ = UserViewR + viewAllRt _ = UserViewAllR + + params _ = [(EntityParam "Ident" userIdent id markupToWidget) + ,(EntityParam "Name" userName mns mnsw) + ,(EntityParam "Address" userAddress mns mnsw) + ,(EntityParam "Telephone" userTelephone mns mnsw) + ] where mns = fromMaybe "not set" + mnsw = maybe [whamlet|not set|] markupToWidget + + viewAllOptions _ = [Asc UserId] + + entName _ = "User" + + form _ proto = return $ renderDivs $ + User + <$> areq textField "Identifier" (fmap userIdent proto) + <*> aopt textField "Name" (fmap userName proto) + <*> aopt textField "Address" (fmap userAddress proto) + <*> aopt textField "Telephone" (fmap userTelephone proto) + + +handleUserNewR :: GHandler master VendUserTest RepHtml +handleUserDeleteR :: Key SqlPersist (UserGeneric SqlPersist) -> GHandler master VendUserTest RepHtml +handleUserEditR :: Key SqlPersist (UserGeneric SqlPersist) -> GHandler master VendUserTest RepHtml +handleUserViewR :: Key SqlPersist (UserGeneric SqlPersist) -> GHandler master VendUserTest RepHtml +handleUserViewAllR :: GHandler master VendUserTest RepHtml + +handleUserNewR = newR UserP +handleUserDeleteR = deleteR UserP +handleUserEditR = editR UserP +handleUserViewR = viewR UserP +handleUserViewAllR = viewAllR UserP + +handleHomeR :: Handler RepHtml +handleHomeR = do + defaultLayout [whamlet|Hello World Dweller! Take a look at this: +
    +
  1. + New #{entName UserP} +
  2. + View all #{entName UserP}s +|] + + +openConnectionCount :: Int +openConnectionCount = 10 + +main :: IO () +main = withSqlitePool "test-usersite.db" openConnectionCount $ \pool -> do + runSqlPool (runMigration migrateAll) pool + warpDebug 3030 $ VendUserTest pool + +instance RenderMessage VendUserTest FormMessage where + renderMessage _ _ = defaultFormMessage diff --git a/src/Yesod/VEND.hs b/src/Yesod/VEND.hs --- a/src/Yesod/VEND.hs +++ b/src/Yesod/VEND.hs @@ -129,12 +129,12 @@ -- | We cannot use record syntax to access fields of existential types. Instead we have: -- -- > epGetText (EntityParam _ pGet pToText _) = pToText . pGet -epGetText :: EntityParam t t1 t2 -> t2 -> Text +epGetText :: EntityParam master sub a -> a -> Text epGetText (EntityParam _ pGet pToText _) = pToText . pGet -- | We cannot use record syntax to access fields of existential types. Instead we have: -- -- > epGetWidget (EntityParam _ pGet _ pToWidget) = pToWidget . pGet -epGetWidget :: EntityParam t t1 t2 -> t2 -> GWidget t t1 () +epGetWidget :: EntityParam master sub a -> a -> GWidget master sub () epGetWidget (EntityParam _ pGet _ pToWidget) = pToWidget . pGet -- | Class for accessing entities referenced by 'a' entity type. For example for entities Foo, Bar: @@ -170,24 +170,26 @@ type FullEntT a :: * type FullEntT a = a + type SiteEntT a + -- | get 'full' entity from base. default implementation works akin to 'get404'. - get404Full :: a -> GHandler master sub (FullEntT a) + get404Full :: a -> GHandler master (SiteEntT a) (FullEntT a) -- | return 'base' type from 'full' type entityCore :: a -> (FullEntT a) -> (EntT a) -- | get a list of parameters describing the 'full' type - paramsFull :: a -> [EntityParam master sub (FullEntT a)] + paramsFull :: a -> [EntityParam master (SiteEntT a) (FullEntT a)] default entityCore :: (EntT a ~ FullEntT a) => a -> (FullEntT a) -> (EntT a) entityCore _ = id - default paramsFull :: ((CRUD a), (ValT a ~ FullEntT a)) => a -> [EntityParam master sub (FullEntT a)] + default paramsFull :: ((SiteEntT a ~ SiteT a), (CRUD a), (ValT a ~ FullEntT a)) => a -> [EntityParam master (SiteEntT a) (FullEntT a)] paramsFull = params - default get404Full :: ((YesodPersistBackend sub ~ SqlPersist), + default get404Full :: ((YesodPersistBackend (SiteEntT a) ~ SqlPersist), (PersistEntity val0), - (YesodPersist sub), + (YesodPersist (SiteEntT a)), (a ~ Key SqlPersist val0), (val0 ~ FullEntT (Key SqlPersist val0))) => - a -> GHandler master sub (FullEntT a) + a -> GHandler master (SiteEntT a) (FullEntT a) get404Full key = runDB (get404 key) -- | Given description of entity parameters ('EntityParam' list) and terse/not terse option return a widget displaying the entity. @@ -202,12 +204,14 @@ |] -- | Core typeclass of this package. Default implementations of handlers use other methods to provide sensible default views. They can be all overriden if needed. -class (EntityDeep (KeyT a)) => CRUD a where +class ((SiteEntT (Key SqlPersist (ValT a)) ~ SiteT a),(EntityDeep (KeyT a))) => CRUD a where -- * types -- | entity value type type ValT a -- | entity key type type KeyT a + -- | site type + type SiteT a -- * stupid methods, we cant just use (undefined :: KeyT a) because of how type families work. -- | provide a value of type 'KeyT a'. Default implementation is 'undefined'. @@ -225,23 +229,23 @@ -- * routes -- | route to 'new element' - newRt :: a -> Route site + newRt :: a -> Route (SiteT a) -- | route to 'view all elements' - viewAllRt :: a -> Route site + viewAllRt :: a -> Route (SiteT a) -- | route to 'view element' - viewRt :: a -> (KeyT a) -> Route site + viewRt :: a -> (KeyT a) -> Route (SiteT a) -- | route to 'delete element' - deleteRt :: a -> (KeyT a) -> Route site + deleteRt :: a -> (KeyT a) -> Route (SiteT a) -- | route to 'edit element' - editRt :: a -> (KeyT a) -> Route site + editRt :: a -> (KeyT a) -> Route (SiteT a) -- * displaying -- | provide widget for displaying an element. Bool argument specifies if this is for \"terse\" view or not. - displayWidget :: a -> (ValT a) -> Bool -> GWidget master sub () + displayWidget :: a -> (ValT a) -> Bool -> GWidget master (SiteT a) () -- | provide widget for displaying element header. Used in 'view all'. - displayHeaderWidget :: a -> Bool -> GWidget master sub () + displayHeaderWidget :: a -> Bool -> GWidget master (SiteT a) () -- | simple version of 'paramsFull' only for 'ValT' type. - params :: a -> [EntityParam master sub (ValT a)] + params :: a -> [EntityParam master (SiteT a) (ValT a)] -- * names -- | entity name. this will be changed in future versions to support proper internationalization. @@ -249,28 +253,28 @@ -- * forms -- | form for creating new entity/editing old one. - form :: a -> (Maybe (ValT a)) -> GHandler master sub (Html -> MForm master sub (FormResult (ValT a), (GWidget master sub ())) ) + form :: a -> (Maybe (ValT a)) -> GHandler master (SiteT a) (Html -> MForm master (SiteT a) (FormResult (ValT a), (GWidget master (SiteT a) ())) ) -- | deletion form. - dForm :: a -> GHandler master sub (Html -> MForm master sub (FormResult Bool, (GWidget master sub ()))) + dForm :: a -> GHandler master (SiteT a) (Html -> MForm master (SiteT a) (FormResult Bool, (GWidget master (SiteT a) ()))) -- * handlers -- | handler for 'viewRt' - viewR :: a -> (KeyT a) -> GHandler master sub RepHtml + viewR :: a -> (KeyT a) -> GHandler master (SiteT a) RepHtml -- | handler for 'editRt' - editR :: a -> (KeyT a) -> GHandler master sub RepHtml + editR :: a -> (KeyT a) -> GHandler master (SiteT a) RepHtml -- | handler for 'newRt' - newR :: a -> GHandler master sub RepHtml + newR :: a -> GHandler master (SiteT a) RepHtml -- | handler for 'deleteRt' - deleteR :: a -> (KeyT a) -> GHandler master sub RepHtml + deleteR :: a -> (KeyT a) -> GHandler master (SiteT a) RepHtml -- | handler for 'viewAllRt' - viewAllR :: a -> GHandler master sub RepHtml + viewAllR :: a -> GHandler master (SiteT a) RepHtml -- default implementations - default params :: (Show (ValT a)) => a -> [EntityParam master sub (ValT a)] + default params :: (Show (ValT a)) => a -> [EntityParam master (SiteT a) (ValT a)] params _ = [EntityParam "shown" show Data.Text.pack markupToWidget] - default displayHeaderWidget :: a -> Bool -> GWidget master sub () + default displayHeaderWidget :: a -> Bool -> GWidget master (SiteT a) () displayHeaderWidget this terse | terse = let pars = paramsFull (getSomeKey this) in [whamlet| #{entName this} @@ -283,7 +287,7 @@ | otherwise = [whamlet|

    #{entName this} |] - default displayWidget :: a -> (ValT a) -> Bool -> GWidget master sub () + default displayWidget :: a -> (ValT a) -> Bool -> GWidget master (SiteT a) () displayWidget this a terse | terse = [whamlet| $forall ep <- params this #{epGetText ep a} |] @@ -294,21 +298,21 @@ #{epGetText ep a} |] - default dForm :: (RenderMessage sub FormMessage) => - a -> GHandler master sub (Html -> MForm master sub (FormResult Bool, (GWidget master sub ()))) + default dForm :: (RenderMessage (SiteT a) FormMessage) => + a -> GHandler master (SiteT a) (Html -> MForm master (SiteT a) (FormResult Bool, (GWidget master (SiteT a) ()))) dForm _this = return $ renderDivs (areq areYouSureField "Are you sure?" (Just False)) where areYouSureField = check isSure boolField isSure False = Left ("You must be sure." :: Text) isSure True = Right True - default newR :: ((Yesod sub), - (YesodPersistBackend sub ~ SqlPersist), - (RenderMessage sub FormMessage), - (YesodPersist sub), + default newR :: ((Yesod (SiteT a)), + (YesodPersistBackend (SiteT a) ~ SqlPersist), + (RenderMessage (SiteT a) FormMessage), + (YesodPersist (SiteT a)), (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => - a -> GHandler master sub RepHtml + a -> GHandler master (SiteT a) RepHtml newR this = do ((result, wg),et) <- runFormPost =<< (form this Nothing) let newForm = (wg,et) @@ -327,13 +331,13 @@ ^{fst newForm} |] - default viewAllR :: ((YesodPersistBackend sub ~ SqlPersist), - (YesodPersist sub), - (Yesod sub), + default viewAllR :: ((YesodPersistBackend (SiteT a) ~ SqlPersist), + (YesodPersist (SiteT a)), + (Yesod (SiteT a)), (EntityDeep (Key SqlPersist (ValT a))), (PersistEntityBackend (ValT a) ~ SqlPersist), (KeyT a ~ Key SqlPersist (ValT a)), - (PersistEntity (ValT a))) => a -> GHandler master sub RepHtml + (PersistEntity (ValT a))) => a -> GHandler master (SiteT a) RepHtml viewAllR this = do values <- runDB $ selectList [] (viewAllOptions this) values'full <- mapM (\ k -> fmap (\ v -> (k,v)) (get404Full k)) (map entityKey values) @@ -372,7 +376,7 @@ Delete |] - default viewR :: ((Yesod sub), (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master sub RepHtml + default viewR :: ((Yesod (SiteT a)), (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master (SiteT a) RepHtml viewR this key = do val'full <- get404Full key defaultLayout $ do @@ -387,11 +391,11 @@ |] - default editR :: ((YesodPersistBackend sub ~ SqlPersist), - (YesodPersist sub), - (Yesod sub), - (RenderMessage sub FormMessage), - (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master sub RepHtml + default editR :: ((YesodPersistBackend (SiteT a) ~ SqlPersist), + (YesodPersist (SiteT a)), + (Yesod (SiteT a)), + (RenderMessage (SiteT a) FormMessage), + (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master (SiteT a) RepHtml editR this key = do val <- runDB $ get404 key ((result,fwidget), enctype) <- runFormPost =<< (form this (Just val)) @@ -414,8 +418,8 @@ ^{fwidget} |] - default deleteR :: ((RenderMessage sub FormMessage), (YesodPersist sub), (YesodPersistBackend sub ~ SqlPersist), (Yesod sub), - (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master sub RepHtml + default deleteR :: ((RenderMessage (SiteT a) FormMessage), (YesodPersist (SiteT a)), (YesodPersistBackend (SiteT a) ~ SqlPersist), (Yesod (SiteT a)), + (KeyT a ~ Key SqlPersist (ValT a)), (PersistEntity (ValT a))) => a -> (KeyT a) -> GHandler master (SiteT a) RepHtml deleteR this key = do val'full <- get404Full key ((result,fwidget), enctype) <- runFormPost =<< (dForm this) @@ -446,7 +450,7 @@ _ -> True -- this makes terse default -- | make 'GWidget' from any type that implements 'ToMarkup' -markupToWidget :: ToMarkup a => a -> GWidget sub master () +markupToWidget :: ToMarkup a => a -> GWidget master sub () markupToWidget t = [whamlet|#{t}|] -- fst3 (v,_,_) = v diff --git a/yesod-vend.cabal b/yesod-vend.cabal --- a/yesod-vend.cabal +++ b/yesod-vend.cabal @@ -1,5 +1,5 @@ Name: yesod-vend -Version: 0.1 +Version: 0.2.0.0 Synopsis: Simple CRUD classes for easy view creation for Yesod Description: Simple CRUD classes for easy view creation for Yesod. See @Yesod.VEND@ for more informations and description how to use it. License: BSD3 @@ -8,7 +8,9 @@ Maintainer: gtener@gmail.com Category: Web, Yesod Build-type: Simple -Cabal-version: >=1.2 +Cabal-version: >=1.8 +Homepage: https://github.com/Tener/yesod-vend +Bug-Reports: https://github.com/Tener/yesod-vend/issues Library Exposed-modules: Yesod.VEND @@ -20,3 +22,21 @@ , blaze-html , hamlet , yesod + +Executable vend-test-user + Main-is: examples/usersite.hs + Build-depends: yesod-vend + , base > 4 && <5 + , yesod-platform > 1.0 && < 1.1 + , persistent + , persistent-sqlite + , text + , blaze-html + , hamlet + , yesod + -- hack around missing -lpthread in persistent-sqlite + Ghc-options: -optl-pthread + +Source-Repository head + Type: git + Location: https://github.com/Tener/yesod-vend.git