yesod-vend 0.1 → 0.2.0.0
raw patch · 3 files changed
+183/−49 lines, 3 filesdep +persistent-sqlitedep +yesod-vendnew-component:exe:vend-test-user
Dependencies added: persistent-sqlite, yesod-vend
Files
- examples/usersite.hs +110/−0
- src/Yesod/VEND.hs +51/−47
- yesod-vend.cabal +22/−2
+ examples/usersite.hs view
@@ -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|<i>not set</i>|] 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:+<ol>+ <li> + <a href=@{newRt UserP}> New #{entName UserP}+ <li> + <a href=@{viewAllRt UserP}> 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
src/Yesod/VEND.hs view
@@ -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| <tr> <th colspan="20"> #{entName this}@@ -283,7 +287,7 @@ | otherwise = [whamlet| <p> #{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 <td> #{epGetText ep a} |]@@ -294,21 +298,21 @@ <span .param> #{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} <input type="submit"> |] - 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 @@ <a href=@{deleteRt this key}> <strong> Delete </strong> |] - 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} <input type="submit"> |] - 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
yesod-vend.cabal view
@@ -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