Permalink
Browse files

yesod 1.2

  • Loading branch information...
1 parent 2819281 commit 3f149f8cf4ce7ffdb3512bcaa13fd0558e01baaa @snoyberg committed Mar 15, 2013
View
@@ -53,7 +53,7 @@ mkYesodDispatch "App" resourcesApp
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
makeApplication conf = do
foundation <- makeFoundation conf
- app <- toWaiAppPlain foundation
+ app <- toWaiApp foundation
return $ logWare app
where
logWare = if development then logStdoutDev
View
@@ -35,6 +35,7 @@ import Yesod.Auth.Facebook
import Facebook (Credentials (Credentials))
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
+import Control.Monad.Trans.Class (lift)
import Network.HTTP.Conduit (Manager)
import Control.Monad (unless)
import Data.Char (isSpace)
@@ -123,9 +124,9 @@ mkMessage "App" "messages" "en"
-- split these actions into two functions and place them in separate files.
mkYesodData "App" $(parseRoutesFile "config/routes")
-type Form x = Html -> MForm App App (FormResult x, Widget)
+type Form x = Html -> MForm Handler (FormResult x, Widget)
-maybeAuth' :: GHandler s App (Maybe ((UserId, User), Maybe Username))
+maybeAuth' :: Handler (Maybe ((UserId, User), Maybe Username))
maybeAuth' = do
x <- maybeAuth
case x of
@@ -134,7 +135,7 @@ maybeAuth' = do
y <- runDB $ getBy $ UniqueUsernameUser uid
return $ Just ((uid, u), fmap entityVal y)
-requireAuth' :: GHandler s App ((UserId, User), Maybe Username)
+requireAuth' :: Handler ((UserId, User), Maybe Username)
requireAuth' = do
Entity uid u <- requireAuth
y <- runDB $ getBy $ UniqueUsernameUser uid
@@ -167,9 +168,8 @@ instance Yesod App where
y <- getYesod
(title', parents) <- breadcrumbs
current <- getCurrentRoute
- tm <- getRouteToMaster
let bodyClass =
- case fmap tm current of
+ case current of
Just UsersR -> "find-haskeller"
Just UserR{} -> "find-haskeller"
Just JobsR -> "find-job"
@@ -179,12 +179,12 @@ instance Yesod App where
Just TopicsR{} -> "teams"
Just TopicR{} -> "teams"
_ -> "overview" :: T.Text
- let title = if fmap tm current == Just RootR
+ let title = if current == Just RootR
then "Haskellers"
else title'
let isCurrent :: Route App -> Bool
- isCurrent RootR = fmap tm current == Just RootR
- isCurrent x = Just x == fmap tm current || x `elem` map fst parents
+ isCurrent RootR = current == Just RootR
+ isCurrent x = Just x == current || x `elem` map fst parents
let navbarSection :: (String, [(String, Route App)])
-> HtmlUrlI18n AppMessage (Route App)
navbarSection section = $(ihamletFile "templates/navbar-section.hamlet")
@@ -200,7 +200,7 @@ instance Yesod App where
toWidget $(Settings.juliusFile "templates/analytics.julius")
toWidget $(Settings.juliusFile "templates/default-layout.julius")
addScriptRemote "https://browserid.org/include.js"
- addWidget widget
+ widget
let login' = $(ihamletFile "templates/login.hamlet")
let langs :: [(Text, Text)]
langs =
@@ -215,9 +215,7 @@ instance Yesod App where
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
- makeSessionBackend _ = do
- key <- getKey "config/client_session_key.aes"
- return . Just $ clientSessionBackend key 120
+ makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 "config/client_session_key.aes"
-- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticRoot setting in Settings.hs
@@ -482,12 +480,9 @@ instance YesodAuth App where
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
- loginHandler = defaultLayout $ do
- [whamlet|\
-<div style="width:500px;margin:0 auto">^{login}
-|]
+ loginHandler = lift $ defaultLayout $ [whamlet|<div style="width:500px;margin:0 auto">^{login}|]
-login :: GWidget s App ()
+login :: Widget
login = toWidget $ {-addCassius $(cassiusFile "login") >> -}$(hamletFile "templates/login.hamlet")
userR :: ((UserId, User), Maybe Username) -> Route App
@@ -585,7 +580,7 @@ userFullName =
browserIdDest :: AuthRoute
browserIdDest = PluginR "browserid" []
-fixBrowserId :: Creds App -> GHandler sub App ()
+fixBrowserId :: Creds App -> Handler ()
fixBrowserId creds
| credsPlugin creds == "browserid" = runDB $ do
liftIO $ putStrLn "here i am"
View
@@ -77,7 +77,7 @@ getMessagesR = do
setTitle "Admin Messages"
$(widgetFile "messages")
-getMessagesFeedR :: Handler RepAtomRss
+getMessagesFeedR :: Handler TypedContent
getMessagesFeedR = do
messages <- runDB $ selectList [MessageClosed ==. False] [Desc MessageWhen, LimitTo 10]
updated <-
View
@@ -68,7 +68,7 @@ postSendVerifyR = do
, sesSecretKey = secret
}
h <- getYesod
- lift $ renderSendMailSES (httpManager h) ses Mail
+ renderSendMailSES (httpManager h) ses Mail
{ mailHeaders =
[ ("Subject", "Verify your email address")
]
View
@@ -17,7 +17,7 @@ import Control.Monad (unless)
import Yesod.Feed
import Yesod.Auth
-jobFormlet :: UserId -> UTCTime -> Maybe Job -> Html -> MForm Haskellers Haskellers (FormResult Job, Widget)
+jobFormlet :: UserId -> UTCTime -> Maybe Job -> Form Job
jobFormlet uid now mj = renderTable $ Job
<$> pure (fromMaybe uid (fmap jobPostedBy mj))
<*> pure (fromMaybe now (fmap jobPostedAt mj))
@@ -54,7 +54,7 @@ getJobsR = do
return $ Just form
else return Nothing
defaultLayout $ do
- addCassius $(cassiusFile "templates/login-status.cassius")
+ toWidget $(cassiusFile "templates/login-status.cassius")
$(widgetFile "jobs")
postJobsR :: Handler RepHtml
@@ -82,7 +82,7 @@ getJobR jid = do
poster <- runDB $ get404 $ jobPostedBy job
defaultLayout $(widgetFile "job")
-getJobsFeedR :: Handler RepAtomRss
+getJobsFeedR :: Handler TypedContent
getJobsFeedR = do
cacheSeconds 7200
now <- liftIO getCurrentTime
View
@@ -15,7 +15,7 @@ import Handler.Admin (requireAdmin)
import Data.Time (getCurrentTime)
import Data.Text (Text)
-newsForm :: Html -> MForm Haskellers Haskellers (FormResult (Text, Html), Widget)
+newsForm :: Form (Text, Html)
newsForm = renderTable $ (,)
<$> areq textField "Title" Nothing
<*> areq nicHtmlField "Content"
@@ -66,10 +66,10 @@ getNewsItemR nid = do
n <- runDB $ get404 nid
defaultLayout $ do
setTitle $ toHtml $ newsTitle n
- addCassius $(cassiusFile "templates/news.cassius")
+ toWidget $(cassiusFile "templates/news.cassius")
$(widgetFile "news-item")
-getNewsFeedR :: Handler RepAtomRss
+getNewsFeedR :: Handler TypedContent
getNewsFeedR = do
cacheSeconds 7200
news@(newest:_) <- runDB $ selectList [] [Desc NewsWhen, LimitTo 10]
View
@@ -51,7 +51,7 @@ oiPercent real oi ois
total = sum $ map f ois
f = if real then oiRealCount else oiCount
-toOI :: Entity PollOption -> YesodDB Haskellers Haskellers OptInfo
+toOI :: Entity PollOption -> YesodDB Haskellers OptInfo
toOI (Entity poid po) = do
x <- count [PollAnswerOption ==. poid]
y <- count [PollAnswerOption ==. poid, PollAnswerReal ==. True]
View
@@ -33,15 +33,15 @@ import qualified Data.Text as T
import Data.Char (isDigit)
import Yesod.Static
-screenNameFormlet :: UserId -> Html -> MForm Haskellers Haskellers (FormResult ScreenName, Widget)
+screenNameFormlet :: UserId -> Form ScreenName
screenNameFormlet uid = renderTable $ ScreenName
<$> pure uid
<*> areq (selectFieldList servopts) "Service" Nothing
<*> areq textField "Screen name" Nothing
where
servopts = map (T.pack . show &&& id) [minBound..maxBound]
-userForm :: Int -> User -> Html -> MForm Haskellers Haskellers (FormResult User, Widget)
+userForm :: Int -> User -> Form User
userForm maxY u = renderTable $ User
<$> areq textField "Full name"
{ fsId = Just "full-name"
View
@@ -27,6 +27,7 @@ import Data.Text.ICU.Normalize
import Data.Text (Text, pack, unpack)
import Data.List (sortBy)
import Data.Ord (comparing)
+import Data.Aeson (object)
-- This is a handler function for the GET request method on the RootR
-- resource pattern. All of your resource patterns are defined in
@@ -68,8 +69,8 @@ getRootR = do
addStylesheetEither $ urlJqueryUiCss y
addScriptRemote "http://maps.google.com/maps/api/js?sensor=false"
addScriptRemote "http://google-maps-utility-library-v3.googlecode.com/svn/trunk/markerclusterer/src/markerclusterer.js"
- addCassius $(cassiusFile "templates/jobs.cassius")
- addCassius $(cassiusFile "templates/users.cassius")
+ toWidget $(cassiusFile "templates/jobs.cassius")
+ toWidget $(cassiusFile "templates/users.cassius")
$(widgetFile "homepage")
data Filter = Filter
@@ -120,7 +121,7 @@ applyFilter f p = and
Just FullPartTime -> True
_ -> False
-filterForm :: Int -> Html -> MForm Haskellers Haskellers (FormResult Filter, Widget)
+filterForm :: Int -> Form Filter
filterForm my = renderTable $ (\a b c d e f g _ -> Filter a b c d e $ Location <$> f <*> g)
<$> aopt textField "Name" Nothing
<*> aopt (yearField 1980 my) "Started using Haskell no earlier than" Nothing
@@ -131,7 +132,7 @@ filterForm my = renderTable $ (\a b c d e f g _ -> Filter a b c d e $ Location <
<*> aopt doubleField "Latitude" { fsId = Just "latitude" } Nothing
<*> aopt textField "Order by proximity to:" { fsId = Just "location" } Nothing
-yearField :: Int -> Int -> Field sub master Int
+yearField :: Int -> Int -> Field Handler Int
yearField minY maxY = Field
{ fieldParse = \ss _ -> return $
case ss of
@@ -152,7 +153,7 @@ yearField minY maxY = Field
, fieldEnctype = UrlEncoded
}
-getUsersR :: Handler RepHtmlJson
+getUsersR :: Handler TypedContent
getUsersR = do
y <- getYesod
allProfs <- liftIO $ readIORef $ publicProfiles y
@@ -183,7 +184,7 @@ getUsersR = do
let maxHaskeller = minHaskeller + length profs - 1
let noFilter = (UsersR, [("page", T.pack $ show page)])
render <- getUrlRender
- flip defaultLayoutJson (json render profs) $ do
+ flip defaultLayoutJson (return $ json render profs) $ do
setTitle "Browsing Haskellers"
addScriptRemote "http://maps.google.com/maps/api/js?sensor=false"
$(widgetFile "users")
@@ -206,7 +207,7 @@ gravatar s x = T.concat
hash = pack $ show $ md5 $ L.fromString $ map toLower $ trim $ unpack x
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
-getLocationsR :: Handler RepJson
+getLocationsR :: Handler Value
getLocationsR = do
render <- getUrlRender
users <- runDB $ selectList [ UserLongitude !=. Nothing
@@ -216,7 +217,7 @@ getLocationsR = do
, UserBlocked ==. False
] []
cacheSeconds 3600
- jsonToRepJson $ object
+ return $ object
["locations" .= array (map (go render) users)]
where
go r (Entity uid u@User
View
@@ -9,7 +9,7 @@ module Handler.Skills
import Import
import Handler.Admin (requireAdmin)
-skillFormlet :: Html -> MForm Haskellers Haskellers (FormResult Skill, Widget)
+skillFormlet :: Form Skill
skillFormlet = renderTable $ Skill
<$> areq textField "Skill name" { fsId = Just "skill-name" } Nothing
@@ -24,7 +24,7 @@ postAllSkillsR = do
_ -> setMessage "Invalid skill entered"
redirect AllSkillsR
-getAllSkillsR :: Handler RepHtmlJson
+getAllSkillsR :: Handler TypedContent
getAllSkillsR = do
mu <- maybeAuth
skills' <- runDB $ selectList [] [Asc SkillName] >>= mapM (\(Entity sid s) -> do
@@ -45,7 +45,7 @@ getAllSkillsR = do
defaultLayoutJson (do
setTitle "Browse all skills"
$(widgetFile "skills")
- ) $ object
+ ) $ return $ object
[ "skills" .= array (flip map skills' $ \((sid, Skill name), users) ->
object
[ "id" .= toPathPiece sid
@@ -55,7 +55,7 @@ getAllSkillsR = do
])
]
-getSkillR :: SkillId -> Handler RepHtmlJson
+getSkillR :: SkillId -> Handler TypedContent
getSkillR sid = do
skill <- runDB $ get404 sid
users <- runDB $ do
@@ -70,7 +70,7 @@ getSkillR sid = do
defaultLayoutJson (do
setTitle $ toHtml $ skillName skill
$(widgetFile "skill")
- ) $ object
+ ) $ return $ object
[ "users" .= array (flip map users $ \x@((uid, u), _) -> object
[ "id" .= toPathPiece uid
, "url" .= render (userR x)
View
@@ -40,14 +40,14 @@ canAddTeam ma = do
Nothing -> return False
Just (Entity _ u) -> return $ userVerifiedEmail u && userReal u && not (userBlocked u)
-teamFormlet :: Maybe Team -> Html -> MForm Haskellers Haskellers (FormResult Team, Widget)
+teamFormlet :: Maybe Team -> Form Team
teamFormlet mt = renderTable $ Team
<$> areq textField "Name" (fmap teamName mt)
<*> areq nicHtmlField "Description"
{ fsId = Just "team-desc"
} (fmap teamDesc mt)
-packageFormlet :: TeamId -> Maybe TeamPackage -> Html -> MForm Haskellers Haskellers (FormResult TeamPackage, Widget)
+packageFormlet :: TeamId -> Maybe TeamPackage -> Form TeamPackage
packageFormlet tid mtp = renderTable $ TeamPackage
<$> pure tid
<*> areq textField "Name" (fmap teamPackageName mtp)
@@ -66,7 +66,7 @@ getTeamsR = do
)
let teams = reverse $ sortBy (comparing snd) teams'
defaultLayout $ do
- addWidget $ loginStatus ma
+ toWidget $ loginStatus ma
$(widgetFile "teams")
postTeamsR :: Handler RepHtml
@@ -82,7 +82,7 @@ postTeamsR = do
lift $ setMessage "Your new group has been created"
lift $ redirect $ TeamR tid
_ -> defaultLayout $ do
- addCassius $(cassiusFile "templates/teams.cassius")
+ toWidget $(cassiusFile "templates/teams.cassius")
$(widgetFile "teams-form")
canEditTeam :: TeamId -> Handler (Bool, Maybe TeamUserStatus)
@@ -119,10 +119,10 @@ getTeamR tid = do
((_, form), enctype) <- runFormPost $ teamFormlet $ Just t
((_, addPackage), _) <- runFormPost $ packageFormlet tid Nothing
defaultLayout $ do
- addWidget $ loginStatus ma
- addCassius $(cassiusFile "templates/teams.cassius")
+ toWidget $ loginStatus ma
+ toWidget $(cassiusFile "templates/teams.cassius")
$(widgetFile "team")
- addHamletHead [hamlet|<link href="@{TeamFeedR tid}" type="application/atom+xml" rel="alternate" title="#{teamName t} Updates">
+ toWidgetHead [hamlet|<link href="@{TeamFeedR tid}" type="application/atom+xml" rel="alternate" title="#{teamName t} Updates">
|]
postTeamR :: TeamId -> Handler RepHtml
@@ -137,7 +137,7 @@ postTeamR tid = do
setMessage "Group information updated"
redirect $ TeamR tid
_ -> defaultLayout $ do
- addCassius $(cassiusFile "templates/teams.cassius")
+ toWidget $(cassiusFile "templates/teams.cassius")
$(widgetFile "team-form")
postLeaveTeamR :: TeamId -> Handler ()
@@ -230,7 +230,7 @@ postTeamUnadminR tid uid = do
_ -> notFound
redirect $ TeamR tid
-getTeamFeedR :: TeamId -> Handler RepAtomRss
+getTeamFeedR :: TeamId -> Handler TypedContent
getTeamFeedR tid = runDB $ do
t <- get404 tid
news <- selectList [TeamNewsTeam ==. tid] [Desc TeamNewsWhen, LimitTo 20]
@@ -249,7 +249,7 @@ getTeamFeedR tid = runDB $ do
, feedAuthor = "Haskellers.com"
}
-getUserFeedR :: UserId -> Handler RepAtomRss
+getUserFeedR :: UserId -> Handler TypedContent
getUserFeedR uid = runDB $ do
_ <- get404 uid
tids <- fmap (map $ teamUserTeam . entityVal) $ selectList [TeamUserUser ==. uid] []
Oops, something went wrong.

0 comments on commit 3f149f8

Please sign in to comment.