158 lines
4.7 KiB
Haskell
158 lines
4.7 KiB
Haskell
{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}
|
|
import Yesod
|
|
import Yesod.Widget
|
|
import Yesod.Helpers.Static
|
|
import Yesod.Form.Jquery
|
|
import Yesod.Form.Core
|
|
import Data.Monoid
|
|
import Yesod.Form.Nic
|
|
import Control.Applicative
|
|
import qualified Data.ByteString.Lazy as L
|
|
import System.Directory
|
|
import Control.Monad.Trans.Class
|
|
import Data.Default
|
|
|
|
data HW = HW { hwStatic :: Static }
|
|
mkYesod "HW" [$parseRoutes|
|
|
/ RootR GET
|
|
/form FormR
|
|
/static StaticR Static hwStatic
|
|
/autocomplete AutoCompleteR GET
|
|
/customform CustomFormR GET
|
|
|]
|
|
instance Yesod HW where
|
|
approot _ = ""
|
|
addStaticContent ext _ content = do
|
|
let fn = (base64md5 content) ++ '.' : ext
|
|
liftIO $ createDirectoryIfMissing True "static/tmp"
|
|
liftIO $ L.writeFile ("static/tmp/" ++ fn) content
|
|
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
|
|
|
type Handler = GHandler HW HW
|
|
|
|
instance YesodNic HW
|
|
instance YesodJquery HW where
|
|
urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness"
|
|
wrapper h = [$hamlet|
|
|
#wrapper ^h^
|
|
%footer Brought to you by Yesod Widgets™
|
|
|]
|
|
getRootR = defaultLayout $ wrapper $ do
|
|
i <- newIdent
|
|
setTitle $ string "Hello Widgets"
|
|
addCassius [$cassius|
|
|
#$i$
|
|
color: red
|
|
|]
|
|
addStylesheet $ StaticR $ StaticRoute ["style.css"] []
|
|
addStylesheetRemote "http://localhost:3000/static/style2.css"
|
|
addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
|
|
addScript $ StaticR $ StaticRoute ["script.js"] []
|
|
addHamlet [$hamlet|
|
|
%h1#$i$ Welcome to my first widget!!!
|
|
%p
|
|
%a!href=@RootR@ Recursive link.
|
|
%p
|
|
%a!href=@FormR@ Check out the form.
|
|
%p
|
|
%a!href=@CustomFormR@ Custom form arrangement.
|
|
%p.noscript Your script did not load. :(
|
|
|]
|
|
addHtmlHead [$hamlet|%meta!keywords=haskell|]
|
|
|
|
handleFormR = do
|
|
(res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,)
|
|
<$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing
|
|
<*> stringField ("Another field") (Just "some default text")
|
|
<*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5)
|
|
<*> jqueryDayField def
|
|
{ jdsChangeMonth = True
|
|
, jdsChangeYear = True
|
|
, jdsYearRange = "1900:c+10"
|
|
, jdsNumberOfMonths = Right (2, 3)
|
|
} ("A day field") Nothing
|
|
<*> timeField ("A time field") Nothing
|
|
<*> boolField FormFieldSettings
|
|
{ ffsLabel = "A checkbox"
|
|
, ffsTooltip = ""
|
|
, ffsId = Nothing
|
|
, ffsName = Nothing
|
|
} (Just False)
|
|
<*> jqueryAutocompleteField AutoCompleteR
|
|
(FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing
|
|
<*> nicHtmlField ("HTML")
|
|
(Just $ string "You can put rich text here")
|
|
<*> maybeEmailField ("An e-mail addres") Nothing
|
|
<*> maybeTextareaField "A text area" Nothing
|
|
let mhtml = case res of
|
|
FormSuccess (_, _, _, _, _, _, _, x, _, _) -> Just x
|
|
_ -> Nothing
|
|
let txt = case res of
|
|
FormSuccess (_, _, _, _, _, _, _, _, _, Just x) -> Just x
|
|
_ -> Nothing
|
|
defaultLayout $ do
|
|
addCassius [$cassius|
|
|
.tooltip
|
|
color: #666
|
|
font-style: italic
|
|
|]
|
|
addCassius [$cassius|
|
|
textarea.html
|
|
width: 300px
|
|
height: 150px
|
|
|]
|
|
addWidget [$hamlet|
|
|
$maybe formFailures.res failures
|
|
%ul.errors
|
|
$forall failures f
|
|
%li $f$
|
|
%form!method=post!enctype=$enctype$
|
|
$hidden$
|
|
%table
|
|
^form^
|
|
%tr
|
|
%td!colspan=2
|
|
%input!type=submit
|
|
$maybe mhtml html
|
|
$html$
|
|
$maybe txt t
|
|
$t$
|
|
|]
|
|
setTitle $ string "Form"
|
|
|
|
main = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt
|
|
|
|
getAutoCompleteR :: Handler RepJson
|
|
getAutoCompleteR = do
|
|
term <- runFormGet' $ stringInput "term"
|
|
jsonToRepJson $ jsonList
|
|
[ jsonScalar $ term ++ "foo"
|
|
, jsonScalar $ term ++ "bar"
|
|
, jsonScalar $ term ++ "baz"
|
|
]
|
|
|
|
data Person = Person String Int
|
|
getCustomFormR = do
|
|
let customForm = GForm $ do
|
|
(a1, [b1], c1) <- deform $ stringInput "name"
|
|
(a2, [b2], c2) <- deform $ intInput "age"
|
|
let b = do
|
|
b1' <- extractBody b1
|
|
b2' <- extractBody b2
|
|
addHamlet [$hamlet|
|
|
%p This is a custom layout.
|
|
%h1 Name Follows!
|
|
%p ^b1'^
|
|
%p Age: ^b2'^
|
|
|]
|
|
return (Person <$> a1 <*> a2, b , c1 `mappend` c2)
|
|
(_, wform, enctype) <- runFormGet customForm
|
|
defaultLayout $ do
|
|
form <- extractBody wform
|
|
addHamlet [$hamlet|
|
|
%form
|
|
^form^
|
|
%div
|
|
%input!type=submit
|
|
|]
|