Added blog sample

.gitignore

@@ -3,3 +3,4 @@
 client_session_key.aes
 *.hi
 *.o
+blog.db3

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
--}

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

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