From 65d8e2febd1c5df3a8104a564eb95d9ffe32a5d7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 2 Jul 2010 09:19:26 +0300 Subject: [PATCH] Added blog sample --- .gitignore | 1 + Yesod/Form.hs | 39 ++++++++++++------ Yesod/Yesod.hs | 2 +- blog.hs | 108 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 137 insertions(+), 13 deletions(-) create mode 100644 blog.hs diff --git a/.gitignore b/.gitignore index 31291836..ed9fa968 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ client_session_key.aes *.hi *.o +blog.db3 diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 1bd1916e..4f10e95f 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -29,6 +29,9 @@ module Yesod.Form , htmlField , stringInput , fieldsToTable + , share2 + , mkIsForm + , mapFormXml {- FIXME -- * Create your own formlets , incr @@ -102,6 +105,11 @@ newtype GForm sub y xml a = GForm type Form sub y = GForm sub y (Widget sub y ()) type FormField sub y = GForm sub y [FieldInfo sub y] +mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a +mapFormXml f (GForm g) = GForm $ \e fe -> do + (res, xml, enc) <- g e fe + return (res, f xml, enc) + data FieldInfo sub y = FieldInfo { fiLabel :: Html () , fiTooltip :: Html () @@ -478,6 +486,7 @@ instance Formable Slug where | all (\c -> c `elem` "-_" || isAlphaNum c) x' = Right $ Slug x' | otherwise = Left ["Slug must be alphanumeric, - and _"] +-} share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do @@ -485,8 +494,8 @@ share2 f g a = do g' <- g a return $ f' ++ g' -deriveFormable :: [EntityDef] -> Q [Dec] -deriveFormable = mapM derive +mkIsForm :: [EntityDef] -> Q [Dec] +mkIsForm = mapM derive where derive :: EntityDef -> Q Dec derive t = do @@ -496,24 +505,31 @@ deriveFormable = mapM derive just <- [|pure|] nothing <- [|Nothing|] let just' = just `AppE` ConE (mkName $ entityName t) + string' <- [|string|] + mempty' <- [|mempty|] + mfx <- [|mapFormXml|] + ftt <- [|fieldsToTable|] + let go_ = go ap just' string' mempty' mfx ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] - (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) + (NormalB $ go_ $ 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 $ entityName t) $ map VarP xs]] - (NormalB $ go ap just' $ zip cols xs') + (NormalB $ go_ $ zip cols xs') [] - return $ InstanceD [] (ConT ''Formable + return $ InstanceD [] (ConT ''IsForm `AppT` ConT (mkName $ entityName t)) - [FunD (mkName "formable") [c1, c2]] - go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = - VarE (mkName "sealForm") `AppE` - (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "formable") `AppE` ex) + [FunD (mkName "toForm") [c1, c2]] + go ap just' string' mem mfx ftt a = + let x = foldl (ap' ap) just' $ map (go' string' mem) a + in mfx `AppE` ftt `AppE` x + go' string' mempty' (label, ex) = + let label' = string' `AppE` LitE (StringL label) + in VarE (mkName "toFormField") `AppE` label' + `AppE` mempty' `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String @@ -524,4 +540,3 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs --} diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 14ff1cf1..8c2a3876 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -103,7 +103,7 @@ class Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: Routes a -> GHandler s a (Maybe String) + isAuthorized :: Routes a -> GHandler s a (Maybe String) -- FIXME use a data type that specifies whether authentication is required isAuthorized _ = return Nothing -- | A type-safe, concise method of creating breadcrumbs for pages. For each diff --git a/blog.hs b/blog.hs new file mode 100644 index 00000000..0a9b50c1 --- /dev/null +++ b/blog.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} +import Yesod +import Yesod.Helpers.Auth +import Yesod.Helpers.Crud +import Database.Persist.Sqlite +import Data.Time (Day) + +type Html' = Html () +share2 mkPersist mkIsForm [$persist| +Entry + title String + posted Day Desc + content Html' + deriving +|] +instance Item Entry where + itemTitle = entryTitle + +getAuth = const $ Auth + { authIsOpenIdEnabled = False + , authRpxnowApiKey = Nothing + , authEmailSettings = Nothing + -- | client id, secret and requested permissions + , authFacebook = Just (clientId, secret, ["email"]) + } + where + clientId = "134280699924829" + secret = "a7685e10c8977f5435e599aaf1d232eb" + +data Blog = Blog Connection +type EntryCrud = Crud Blog Entry +mkYesod "Blog" [$parseRoutes| +/ RootR GET +/entry/#EntryId EntryR GET +/admin AdminR EntryCrud defaultCrud +/auth AuthR Auth getAuth +|] +instance Yesod Blog where + approot _ = "http://localhost:3000" + defaultLayout p = do + mcreds <- maybeCreds + admin <- maybeAuthorized $ AdminR CrudListR + hamletToContent [$hamlet| +!!! +%html + %head + %title $pageTitle.p$ + ^pageHead.p^ + %body + %p + %a!href=@RootR@ Homepage + $maybe admin a + \ | $ + %a!href=@a@ Admin + \ | $ + $maybe mcreds c + Welcome $ + $maybe credsDisplayName.c dn + $string.dn$ + $nothing + $string.credsIdent.c$ + \ $ + %a!href=@AuthR.Logout@ Logout + $nothing + %a!href=@AuthR.StartFacebookR@ Facebook Connect + ^pageBody.p^ + %p + Powered by Yesod Web Framework +|] + isAuthorized AdminR{} = do + mc <- maybeCreds + let x = (mc >>= credsEmail) == Just "michael@snoyman.com" + return $ if x then Nothing else Just "Permission denied" + isAuthorized _ = return Nothing +instance YesodAuth Blog where + defaultDest _ = RootR + defaultLoginRoute _ = RootR +instance YesodPersist Blog where + type YesodDB Blog = SqliteReader + runDB db = do + Blog conn <- getYesod + runSqlite db conn + +getRootR = do + entries <- runDB $ select [] [EntryPostedDesc] + applyLayoutW $ do + setTitle $ string "Blog tutorial homepage" + addBody [$hamlet| +%h1 All Entries +%ul + $forall entries entry + %li + %a!href=@EntryR.fst.entry@ $string.entryTitle.snd.entry$ +|] + +getEntryR :: EntryId -> Handler Blog RepHtml +getEntryR eid = do + entry <- runDB (get eid) >>= maybe notFound return + applyLayoutW $ do + setTitle $ string $ entryTitle entry + addBody [$hamlet| +%h1 $string.entryTitle.entry$ +%h2 $string.show.entryPosted.entry$ +#content $entryContent.entry$ +|] +main = withSqlite "blog.db3" $ \conn -> do + flip runSqlite conn $ initialize (undefined :: Entry) + toWaiApp (Blog conn) >>= basicHandler 3000