Skip to content
Browse files

10 random users on homepage

  • Loading branch information...
1 parent 1e498cc commit 29e91276f3a0f37eebc60e8d64a1697004e80d85 @snoyberg committed
Showing with 135 additions and 73 deletions.
  1. +2 −0 API.markdown
  2. +29 −1 Controller.hs
  3. +31 −16 Handler/Root.hs
  4. +9 −0 Haskellers.hs
  5. +1 −1 Model.hs
  6. +0 −19 cassius/homepage.cassius
  7. +19 −0 cassius/users.cassius
  8. +22 −36 hamlet/homepage.hamlet
  9. +21 −0 hamlet/users.hamlet
  10. +1 −0 haskellers.cabal
View
2 API.markdown
@@ -2,6 +2,8 @@ This site runs on a RESTful API. Content is available as JSON. In order to acces
## http://www.haskellers.com/users/
+FIXME: This API is in flux right now, my appologies
+
This returns a list of all publicly-viewable user accounts. The response is a JSON map with one attribute: users. users is a JSON list, each element an array with three elements: id is the numerical ID of the account, name is the user's full name and url is the user's Haskeller URL (the next resource pattern).
## http://www.haskellers.com/user/*id*
View
30 Controller.hs
@@ -9,6 +9,10 @@ import Settings
import Yesod.Helpers.Static
import Yesod.Helpers.Auth2
import Database.Persist.GenericSql
+import Data.IORef
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad (forever)
+import Data.Maybe (mapMaybe)
-- Import all relevant handler modules here.
import Handler.Root
@@ -45,7 +49,31 @@ withHaskellers f = Settings.withConnectionPool $ \p -> do
migrate (undefined :: UserSkill)
migrate (undefined :: Package)
migrate (undefined :: Message)
- let h = Haskellers s p
+ iprofs <- newIORef []
+ _ <- forkIO $ fillProfs p iprofs
+ let h = Haskellers s p iprofs
toWaiApp h >>= f
where
s = fileLookupDir Settings.staticdir typeByExt
+
+getHomepageProfs pool = flip runConnectionPool pool $ do
+ users <-
+ selectList [ UserVerifiedEmailEq True
+ , UserVisibleEq True
+ , UserRealEq True
+ , UserBlockedEq False
+ -- FIXME , UserRealPicEq True
+ ] [] 0 0
+ return $ flip mapMaybe users $ \(uid, u) ->
+ case userEmail u of
+ Nothing -> Nothing
+ Just e -> Just Profile
+ { profileUserId = uid
+ , profileName = userFullName u
+ , profileEmail = e
+ }
+
+fillProfs pool iprofs = forever $ do
+ profs <- getHomepageProfs pool
+ writeIORef iprofs profs
+ threadDelay $ 1000 * 1000 * 60 * 5
View
47 Handler/Root.hs
@@ -1,11 +1,18 @@
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
-module Handler.Root where
+module Handler.Root
+ ( getRootR
+ , getUsersR
+ , gravatar
+ ) where
import Haskellers
import qualified Data.ByteString.Lazy.UTF8 as L
import Data.Digest.Pure.MD5 (md5)
import Data.Char (toLower, isSpace)
import Data.Maybe (fromMaybe)
+import System.Random (newStdGen)
+import System.Random.Shuffle (shuffle')
+import Data.IORef (readIORef)
-- This is a handler function for the GET request method on the RootR
-- resource pattern. All of your resource patterns are defined in
@@ -16,6 +23,10 @@ import Data.Maybe (fromMaybe)
-- inclined, or create a single monolithic file.
getRootR :: Handler RepHtml
getRootR = do
+ y <- getYesod
+ allProfs <- liftIO $ readIORef $ homepageProfiles y
+ gen <- liftIO newStdGen
+ let profs = take 10 $ shuffle' allProfs (length allProfs) gen
mu <- maybeAuth
(public, private, unver) <- runDB $ do
public <- count [ UserVerifiedEmailEq True
@@ -30,14 +41,27 @@ getRootR = do
, UserBlockedEq False
]
return (public, private, unverified)
+ defaultLayout $ do
+ setTitle "Haskellers"
+ addStyle $(cassiusFile "homepage")
+ addStyle $(cassiusFile "users")
+ $(hamletFile "homepage")
+
+getUsersR :: Handler RepHtmlJson
+getUsersR = do
mpage <- runFormGet' $ maybeIntInput "page"
let page = fromMaybe 0 mpage
let perPage = 10
let hasPrev = page > 0
+ public <- runDB $ count
+ [ UserVerifiedEmailEq True
+ , UserVisibleEq True
+ , UserBlockedEq False
+ ]
let maxPage = (public - 1) `div` perPage
let hasNext = page < maxPage
- let next = (RootR, [("page", show $ page + 1)])
- let prev = (RootR, [("page", show $ page - 1)])
+ let next = (UsersR, [("page", show $ page + 1)])
+ let prev = (UsersR, [("page", show $ page - 1)])
let minHaskeller = page * perPage + 1
users <- runDB $ selectList [ UserVerifiedEmailEq True
, UserVisibleEq True
@@ -48,20 +72,10 @@ getRootR = do
, UserFullNameAsc
] perPage (perPage * page)
let maxHaskeller = minHaskeller + length users - 1
- defaultLayout $ do
- setTitle "Haskellers"
- addStyle $(cassiusFile "homepage")
- $(hamletFile "homepage")
- where
- fakeEmail = "fake@email.com"
-
-getUsersR :: Handler RepJson
-getUsersR = do
- users <- runDB $ selectList [ UserVerifiedEmailEq True
- , UserVisibleEq True
- ] [UserFullNameAsc] 0 0
render <- getUrlRender
- jsonToRepJson $ json render users
+ flip defaultLayoutJson (json render users) $ do
+ addStyle $(cassiusFile "users")
+ $(hamletFile "users")
where
json r users = jsonMap [("users", jsonList $ map (json' r) users)]
json' r (uid, u) = jsonMap
@@ -69,6 +83,7 @@ getUsersR = do
, ("name", jsonScalar $ userFullName u)
, ("url", jsonScalar $ r $ UserR uid)
]
+ fakeEmail = "fake@email.com"
gravatar :: Int -> String -> String
gravatar s x =
View
9 Haskellers.hs
@@ -13,6 +13,7 @@ module Haskellers
, AuthRoute (..)
, showIntegral
, login
+ , Profile (..)
) where
import Yesod
@@ -30,6 +31,7 @@ import Model
import StaticFiles (logo_png, jquery_ui_css, google_png, yahoo_png,
openid_icon_small_gif, facebook_png)
import Yesod.Form.Jquery
+import Data.IORef (IORef)
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
@@ -38,6 +40,13 @@ import Yesod.Form.Jquery
data Haskellers = Haskellers
{ getStatic :: Static -- ^ Settings for static file serving.
, connPool :: Settings.ConnectionPool -- ^ Database connection pool.
+ , homepageProfiles :: IORef [Profile]
+ }
+
+data Profile = Profile
+ { profileUserId :: UserId
+ , profileName :: String
+ , profileEmail :: String
}
-- | A useful synonym; most of the handler functions in your application
View
2 Model.hs
@@ -42,7 +42,7 @@ User
haskellSince Int null Asc
desc Textarea null id=desc
visible Bool default=true Eq
- real Bool default=false update Desc
+ real Bool default=false update Desc Eq
admin Bool default=false update
employment Employment null
blocked Bool update Eq default=false
View
19 cassius/homepage.cassius
@@ -18,22 +18,3 @@
padding-top: 15px
border-top: 1px dashed #0e485a
text-align: center
-.user
- display: inline-block
- vertical-align: top
-.user a
- display: block
- width: 120px
- margin: 5px
- text-align: center
- border: 1px solid #aaa
- background: #eee
- padding: 10px 3px
- font-size: 80%
-.user span.name
- display: block
-.user img
- border: 0
- padding-right: 10px
-.note
- font-style: italic
View
19 cassius/users.cassius
@@ -0,0 +1,19 @@
+.user
+ display: inline-block
+ vertical-align: top
+.user a
+ display: block
+ width: 120px
+ margin: 5px
+ text-align: center
+ border: 1px solid #aaa
+ background: #eee
+ padding: 10px 3px
+ font-size: 80%
+.user span.name
+ display: block
+.user img
+ border: 0
+ padding-right: 10px
+.note
+ font-style: italic
View
58 hamlet/homepage.hamlet
@@ -1,41 +1,27 @@
-$if not.hasPrev
- #topbar
- #blurb
- Haskellers is a centralized place for professional Haskell programmers to publish themselves. If you'd like to create a profile, simply log in on the right. If you are looking for a Haskeller, just continue down the page.
- #login
- $maybe mu u
- %p
- You are logged in as
- %br
- %b $userFullName'.snd.u$
- %br
- %a!href=@ProfileR@ Edit my Profile
- %br
- %a!href=@AuthR.LogoutR@ Logout
- $nothing
- %h3 Login with
- ^login^
+#topbar
+ #blurb
+ Haskellers is a centralized place for professional Haskell programmers to publish themselves. If you'd like to create a profile, simply log in on the right. If you are looking for a Haskeller, just continue down the page.
+ #login
+ $maybe mu u
+ %p
+ You are logged in as
+ %br
+ %b $userFullName'.snd.u$
+ %br
+ %a!href=@ProfileR@ Edit my Profile
+ %br
+ %a!href=@AuthR.LogoutR@ Logout
+ $nothing
+ %h3 Login with
+ ^login^
#users
.counts
Total accounts: $show.public$ public, $show.private$ private, $show.unver$ unverified.
- .controls
- $if hasPrev
- %a!href=@?prev@ Previous
- $else
- Previous
- %b
- \ Viewing Haskellers $show.minHaskeller$-$show.maxHaskeller$ $
- $if hasNext
- %a!href=@?next@ Next
- $else
- Next
- $forall users user
+ $forall profs prof
.user
- %a!href=@UserR.fst.user@
- $maybe userEmail.snd.user email
- %img!src=$(gravatar.80).email$!alt="Gravatar Profile Picture"
- $nothing
- %img!src=$(gravatar.80).fakeEmail$!alt="Gravatar Profile Picture"
+ %a!href=@UserR.profileUserId.prof@
+ %img!src=$(gravatar.80).profileEmail.prof$!alt="Gravatar Profile Picture"
%span.name
- $userFullName'.snd.user$
- .note Note: Haskellers are sorted by years of experience with Haskell. Also, approved accounts are shown first.
+ $profileName.prof$
+ %p
+ %a!href=@UsersR@ Browse all public Haskellers
View
21 hamlet/users.hamlet
@@ -0,0 +1,21 @@
+.controls
+ $if hasPrev
+ %a!href=@?prev@ Previous
+ $else
+ Previous
+ %b
+ \ Viewing Haskellers $show.minHaskeller$-$show.maxHaskeller$ $
+ $if hasNext
+ %a!href=@?next@ Next
+ $else
+ Next
+$forall users user
+ .user
+ %a!href=@UserR.fst.user@
+ $maybe userEmail.snd.user email
+ %img!src=$(gravatar.80).email$!alt="Gravatar Profile Picture"
+ $nothing
+ %img!src=$(gravatar.80).fakeEmail$!alt="Gravatar Profile Picture"
+ %span.name
+ $userFullName'.snd.user$
+.note Note: Haskellers are sorted by years of experience with Haskell. Also, verified users are shown first.
View
1 haskellers.cabal
@@ -35,6 +35,7 @@ executable simple-server
random,
HsOpenSSL,
time,
+ random-shuffle,
utf8-string
ghc-options: -Wall
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies

0 comments on commit 29e9127

Please sign in to comment.
Something went wrong with that request. Please try again.