htmlField and fixed auth

Yesod/Form.hs

@@ -8,18 +8,26 @@
 -- | Parse forms (and query strings).
 module Yesod.Form
     ( -- * Data types
-      Form (..)
+      GForm (..)
+    , Form
+    , FormField
     , FormResult (..)
       -- * Unwrapping functions
     , runFormGet
     , runFormPost
     , runFormGet'
     , runFormPost'
+      -- * Type classes
+    , IsForm (..)
+    , IsFormField (..)
+      -- * Pre-built fields
     , requiredField
     , stringField
     , intField
     , dayField
     , boolField
+    , htmlField
+    , stringInput
     , fieldsToTable
     {- FIXME
       -- * Create your own formlets
@@ -60,7 +68,7 @@ import Data.Char (isAlphaNum, toUpper, isUpper)
 import Data.Maybe (isJust)
 import Web.Routes.Quasi (SinglePiece)
 import Data.Int (Int64)
-import qualified Data.ByteString.Lazy.UTF8
+import qualified Data.ByteString.Lazy.UTF8 as U
 import Yesod.Widget
 
 data FormResult a = FormMissing
@@ -81,8 +89,8 @@ instance Applicative FormResult where
 
 data Enctype = UrlEncoded | Multipart
 instance Show Enctype where
-    show UrlEncoded = "urlencoded"
+    show UrlEncoded = "application/x-www-form-urlencoded"
-    show Multipart = "multipart/mimetype" -- FIXME
+    show Multipart = "multipart/form-data"
 instance Monoid Enctype where
     mempty = UrlEncoded
     mappend UrlEncoded UrlEncoded = UrlEncoded
@@ -133,6 +141,11 @@ fieldsToTable = mapM_ go
         $fiErrors.fi$
 |]
 
+class IsForm a where
+    toForm :: Maybe a -> Form sub y a
+class IsFormField a where
+    toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a
+
 requiredField :: FieldProfile sub y a
               -> Html () -> Html () -> Maybe a -> FormField sub y a
 requiredField (FieldProfile parse render mkXml w) label tooltip orig =
@@ -177,6 +190,8 @@ stringField = FieldProfile
 |]
     , fpWidget = \_name -> return ()
     }
+instance IsFormField String where
+    toFormField = requiredField stringField
 
 intField :: FieldProfile sub y Int
 intField = FieldProfile
@@ -187,6 +202,8 @@ intField = FieldProfile
 |]
     , fpWidget = \_name -> return ()
     }
+instance IsFormField Int where
+    toFormField = requiredField intField
 
 dayField :: FieldProfile sub y Day
 dayField = FieldProfile
@@ -202,6 +219,8 @@ dayField = FieldProfile
         addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
         addHead [$hamlet|%script $$(function(){$$("#$string.name$").datepicker({dateFormat:'yy-mm-dd'})})|]
     }
+instance IsFormField Day where
+    toFormField = requiredField dayField
 
 boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
 boolField label tooltip orig = GForm $ \env _ -> do
@@ -224,6 +243,23 @@ boolField label tooltip orig = GForm $ \env _ -> do
                             _ -> string ""
             }
     return (res, [fi], UrlEncoded)
+instance IsFormField Bool where
+    toFormField = boolField
+
+htmlField :: FieldProfile sub y (Html ())
+htmlField = FieldProfile
+    { fpParse = Right . preEscapedString
+    , fpRender = U.toString . renderHtml
+    , fpHamlet = \name val isReq -> [$hamlet|
+%textarea#$name$!name=$name$ $val$
+|]
+    , fpWidget = \name -> do
+        addScriptRemote "http://js.nicedit.com/nicEdit-latest.js"
+        addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|]
+        addStyle [$hamlet|\#$string.name${min-width:400px;min-height:300px}|]
+    }
+instance IsFormField (Html ()) where
+    toFormField = requiredField htmlField
 
 readMay :: Read a => String -> Maybe a
 readMay s = case reads s of
@@ -232,6 +268,17 @@ readMay s = case reads s of
 
 --------------------- End prebuilt forms
 
+--------------------- Begin prebuilt inputs
+
+stringInput :: String -> Form sub master String
+stringInput n = GForm $ \env _ -> return
+    (case lookup n env of
+        Nothing -> FormMissing
+        Just "" -> FormFailure [n ++ ": You must provide a non-empty string"]
+        Just x -> FormSuccess x, mempty, UrlEncoded)
+
+--------------------- End prebuilt inputs
+
 incr :: Monad m => StateT Int m String
 incr = do
     i <- get
@@ -324,7 +371,7 @@ instance Formable (Maybe String) where
 instance Formable (Html ()) where
     formable = fmap preEscapedString
               . input go
-              . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
+              . fmap (U.toString . renderHtml)
       where
         go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
 

Yesod/Helpers/Auth.hs

@@ -182,7 +182,7 @@ $maybe message msg
 getOpenIdForward :: GHandler Auth master ()
 getOpenIdForward = do
     testOpenId
-    oid <- runFormGet' $ requiredField "openid"
+    oid <- runFormGet' $ stringInput "openid"
     render <- getUrlRender
     toMaster <- getRouteToMaster
     let complete = render $ toMaster OpenIdComplete
@@ -302,7 +302,7 @@ getEmailRegisterR = do
 postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
 postEmailRegisterR = do
     ae <- getAuthEmailSettings
-    email <- runFormPost' $ notEmptyField "email" -- FIXME checkEmail
+    email <- runFormPost' $ stringInput "email" -- FIXME checkEmail
     y <- getYesod
     mecreds <- liftIO $ getEmailCreds ae email
     (lid, verKey) <-
@@ -367,8 +367,8 @@ postEmailLoginR :: YesodAuth master => GHandler Auth master ()
 postEmailLoginR = do
     ae <- getAuthEmailSettings
     (email, pass) <- runFormPost' $ (,)
-        <$> notEmptyField "email" -- FIXME valid e-mail?
+        <$> stringInput "email" -- FIXME valid e-mail?
-        <*> requiredField "password"
+        <*> stringInput "password"
     y <- getYesod
     mecreds <- liftIO $ getEmailCreds ae email
     let mlid =
@@ -420,8 +420,8 @@ postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
 postEmailPasswordR = do
     ae <- getAuthEmailSettings
     (new, confirm) <- runFormPost' $ (,)
-        <$> notEmptyField "new"
+        <$> stringInput "new"
-        <*> notEmptyField "confirm"
+        <*> stringInput "confirm"
     toMaster <- getRouteToMaster
     when (new /= confirm) $ do
         setMessage $ string "Passwords did not match, please try again"
@@ -495,7 +495,7 @@ getFacebookR = do
             render <- getUrlRender
             tm <- getRouteToMaster
             let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
-            code <- runFormGet' $ requiredField "code"
+            code <- runFormGet' $ stringInput "code"
             at <- liftIO $ Facebook.getAccessToken fb code
             so <- liftIO $ Facebook.getGraphData at "me"
             let c = fromMaybe (error "Invalid response from Facebook") $ do

Yesod/Helpers/Crud.hs

@@ -19,7 +19,7 @@ import Text.Hamlet
 import Yesod.Form
 import Data.Monoid (mempty)
 
-class Formable a => Item a where
+class IsForm a => Item a where
     itemTitle :: a -> String
 
 data Crud master item = Crud
@@ -133,7 +133,7 @@ crudHelper
     -> GHandler (Crud master a) master RepHtml
 crudHelper title me isPost = do
     crud <- getYesodSub
-    (errs, form) <- runFormPost $ formable $ fmap snd me
+    (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me
     toMaster <- getRouteToMaster
     case (isPost, errs) of
         (True, FormSuccess a) -> do
@@ -146,21 +146,21 @@ crudHelper title me isPost = do
                                        $ toSinglePiece eid
         _ -> return ()
     applyLayoutW $ do
-        wrapWidget (wrapForm toMaster) form
+        wrapWidget (wrapForm toMaster enctype) form
         setTitle $ string title
   where
-    wrapForm toMaster form = [$hamlet|
+    wrapForm toMaster enctype form = [$hamlet|
 %p
     %a!href=@toMaster.CrudListR@ Return to list
 %h1 $string.title$
-%form!method=post
+%form!method=post!enctype=$string.show.enctype$
     %table
         ^form^
         %tr
             %td!colspan=2
                 %input!type=submit
                 $maybe me e
-                    \ 
+                    \ $
                     %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
 |]
 

hellowidget.hs

@@ -34,12 +34,17 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do
     addHead [$hamlet|%meta!keywords=haskell|]
 
 handleFormR = do
-    (res, form, enctype) <- runFormPost $ (,,,,)
+    (res, form, enctype) <- runFormPost $ (,,,,,)
         <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing
         <*> requiredField stringField (string "Another field") (string "") (Just "some default text")
         <*> requiredField intField (string "A number field") (string "some nums") (Just 5)
         <*> requiredField dayField (string "A day field") (string "") Nothing
         <*> boolField (string "A checkbox") (string "") (Just False)
+        <*> requiredField htmlField (string "HTML") (string "")
+                (Just $ string "You can put rich text here")
+    let mhtml = case res of
+                    FormSuccess (_, _, _, _, _, x) -> Just x
+                    _ -> Nothing
     applyLayoutW $ do
         addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|]
         flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet|
@@ -49,8 +54,8 @@ handleFormR = do
         %tr
             %td!colspan=2
                 %input!type=submit
-    %h3
+    $maybe mhtml html
-        Result: $string.show.res$
+        $html$
 |]
         setTitle $ string "Form"