Permalink
Browse files

fruitful case study

  • Loading branch information...
0 parents commit cd96e18da31a47d945adf4c6e2fd3f918671d119 @astro committed Jun 24, 2012
Showing with 9,786 additions and 0 deletions.
  1. +99 −0 Application.hs
  2. +165 −0 Foundation.hs
  3. +96 −0 Handler/Browse.hs
  4. +39 −0 Handler/Home.hs
  5. +28 −0 Import.hs
  6. +25 −0 LICENSE
  7. +81 −0 Model.hs
  8. +63 −0 Settings.hs
  9. +14 −0 Settings/Development.hs
  10. +18 −0 Settings/StaticFiles.hs
  11. +2 −0 config/client_session_key.aes
  12. BIN config/favicon.ico
  13. +11 −0 config/models
  14. +21 −0 config/postgresql.yml
  15. +1 −0 config/robots.txt
  16. +9 −0 config/routes
  17. +19 −0 config/settings.yml
  18. +97 −0 deploy/Procfile
  19. +26 −0 devel.hs
  20. +8 −0 main.hs
  21. +1 −0 messages/en.msg
  22. +118 −0 prittorrent-hui.cabal
  23. BIN static/404.jpg
  24. BIN static/500.jpg
  25. BIN static/activate-account.png
  26. +52 −0 static/activate.js
  27. BIN static/atom.png
  28. BIN static/audio.png
  29. +82 −0 static/audio.svg
  30. BIN static/bitlove-button.png
  31. BIN static/d.png
  32. +109 −0 static/d.svg
  33. BIN static/dl.gif
  34. BIN static/download.png
  35. +109 −0 static/download.svg
  36. +162 −0 static/edit-feed.js
  37. +152 −0 static/edit-user.js
  38. BIN static/edit.png
  39. +315 −0 static/error.svg
  40. BIN static/favicon.png
  41. +205 −0 static/filter.js
  42. +245 −0 static/graphs.js
  43. BIN static/help-podcaster-feed.png
  44. +295 −0 static/help-podcaster-feed.svg
  45. BIN static/img/glyphicons-halflings-white.png
  46. BIN static/img/glyphicons-halflings.png
  47. +4 −0 static/jquery-1.7.1.min.js
  48. +2,697 −0 static/jquery.flot.js
  49. +1,165 −0 static/jsSHA.js
  50. BIN static/l.png
  51. +142 −0 static/l.svg
  52. +62 −0 static/login.js
  53. BIN static/logo.png
  54. +260 −0 static/logo.svg
  55. BIN static/mail-bird.png
  56. BIN static/podpress-widget.png
  57. BIN static/powerpress-widget.png
  58. BIN static/rss.png
  59. BIN static/s.png
  60. +102 −0 static/s.svg
  61. +19 −0 static/signup.js
  62. BIN static/stub.png
  63. +264 −0 static/stub.svg
  64. +886 −0 static/style.css
  65. BIN static/swarm.png
  66. +288 −0 static/swarm.svg
  67. +1 −0 static/tmp/1sifjTMs.js
  68. +160 −0 static/tmp/GKy_B1VG.css
  69. +3 −0 static/tmp/ONzb8a8l.css
  70. +3 −0 static/tmp/UEG9zQsl.css
  71. +1 −0 static/tmp/x0PsQ9Am.css
  72. BIN static/torrent.png
  73. +253 −0 static/torrent.svg
  74. BIN static/torrentify.png
  75. +103 −0 static/u.js
  76. BIN static/video.png
  77. +153 −0 static/video.svg
  78. +66 −0 templates/default-layout-wrapper.hamlet
  79. +3 −0 templates/default-layout.hamlet
  80. +38 −0 templates/homepage.hamlet
  81. +1 −0 templates/homepage.julius
  82. +6 −0 templates/homepage.lucius
  83. +439 −0 templates/normalize.lucius
@@ -0,0 +1,99 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Application
+ ( makeApplication
+ , getApplicationDev
+ , makeFoundation
+ ) where
+
+import Import
+import Settings
+import Yesod.Auth
+import Yesod.Default.Config
+import Yesod.Default.Main
+import Yesod.Default.Handlers
+import Yesod.Logger (Logger, logBS, toProduction)
+import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev)
+import Network.HTTP.Conduit (newManager, def)
+import Data.Conduit.Pool
+import Database.HDBC as HDBC (disconnect)
+import Database.HDBC.PostgreSQL
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Text as Text
+import Debug.Trace
+
+
+-- Import all relevant handler modules here.
+-- Don't forget to add new modules to your cabal file!
+import Handler.Home
+import Handler.Browse
+
+-- This line actually creates our YesodSite instance. It is the second half
+-- of the call to mkYesodData which occurs in Foundation.hs. Please see
+-- the comments there for more details.
+mkYesodDispatch "App" resourcesApp
+
+-- This function allocates resources (such as a database connection pool),
+-- performs initialization and creates a WAI application. This is also the
+-- place to put your migrate statements to have automatic database
+-- migrations handled by Yesod.
+makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application
+makeApplication conf logger = do
+ foundation <- makeFoundation conf setLogger
+ app <- toWaiAppPlain foundation
+ return $ logWare app
+ where
+ setLogger = if development then logger else toProduction logger
+ logWare = if development then logCallbackDev (logBS setLogger)
+ else logCallback (logBS setLogger)
+
+makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App
+makeFoundation conf setLogger = do
+ manager <- newManager def
+ s <- staticSite
+ dbconf <- withYamlEnvironment
+ "config/postgresql.yml"
+ (appEnv conf)
+ parseDBConf
+ pool <- makeDBPool dbconf
+ return $ App conf setLogger s pool manager
+
+parseDBConf = return . parse
+ where parse (Aeson.Object o) = do
+ (k, v) <- HashMap.toList o
+ let k' = Text.unpack k
+ case v of
+ Aeson.String v' ->
+ return (k', Text.unpack v')
+ (Aeson.Object _) ->
+ parse v
+ (Aeson.Number n) ->
+ return (k', show n)
+ _ ->
+ trace ("Cannot parse: " ++ show v) []
+
+makeDBPool :: [(String, String)] -> IO DBPool
+makeDBPool dbconf =
+ let dbconf' :: [([Char], [Char])]
+ dbconf' = filter (\(k, v) ->
+ k `elem` ["host", "hostaddr",
+ "port", "dbname",
+ "user", "password"]
+ ) dbconf
+ dbconf'' = unwords $
+ map (\(k, v) ->
+ k ++ "=" ++ v
+ ) dbconf'
+ in createPool
+ (connectPostgreSQL dbconf'')
+ HDBC.disconnect
+ 4 5 4
+
+-- for yesod devel
+getApplicationDev :: IO (Int, Application)
+getApplicationDev =
+ defaultDevelApp loader makeApplication
+ where
+ loader = loadConfig (configSettings Development)
+ { csParseExtra = parseExtra
+ }
@@ -0,0 +1,165 @@
+{-# LANGUAGE RankNTypes #-}
+module Foundation
+ ( App (..)
+ , Route (..)
+ , AppMessage (..)
+ , resourcesApp
+ , Handler
+ , Widget
+ , Form
+ , withDB, DBPool
+ , Period (..)
+ --, maybeAuth
+ --, requireAuth
+ , module Settings
+ , module Model
+ ) where
+
+import Prelude
+import Yesod
+import Yesod.Static
+--import Yesod.Auth
+import Yesod.Default.Config
+import Yesod.Default.Util (addStaticContentExternal)
+import Yesod.Logger (Logger, logMsg, formatLogText)
+import Network.HTTP.Conduit (Manager)
+import qualified Settings
+import Settings.StaticFiles
+import Settings (widgetFile, Extra (..))
+import Model
+import Text.Jasmine (minifym)
+import Web.ClientSession (getKey)
+import Text.Hamlet (hamletFile)
+import Control.Applicative
+import Data.Conduit.Pool
+import Control.Monad.Trans.Resource
+import qualified Database.HDBC.PostgreSQL as PostgreSQL (Connection)
+import qualified Data.Text as T
+
+
+type DBPool = Pool PostgreSQL.Connection
+
+
+data Period = PeriodDays Int
+ | PeriodAll
+ deriving (Show, Eq, Read, Ord)
+
+instance PathPiece Period where
+ fromPathPiece text =
+ case T.unpack text of
+ "1" -> Just $ PeriodDays 1
+ "7" -> Just $ PeriodDays 7
+ "30" -> Just $ PeriodDays 30
+ "all" -> Just $ PeriodAll
+ _ -> Nothing
+
+-- | The site argument for your application. This can be a good place to
+-- keep settings and values requiring initialization before your application
+-- starts running, such as database connections. Every handler will have
+-- access to the data present here.
+data App = App
+ { settings :: AppConfig DefaultEnv Extra
+ , getLogger :: Logger
+ , getStatic :: Static -- ^ Settings for static file serving.
+ , dbPool :: DBPool -- ^ Database connection pool.
+ , httpManager :: Manager
+ }
+
+-- Set up i18n messages. See the message folder.
+mkMessage "App" "messages" "en"
+
+-- This is where we define all of the routes in our application. For a full
+-- explanation of the syntax, please see:
+-- http://www.yesodweb.com/book/handler
+--
+-- This function does three things:
+--
+-- * Creates the route datatype AppRoute. Every valid URL in your
+-- application can be represented as a value of this type.
+-- * Creates the associated type:
+-- type instance Route App = AppRoute
+-- * Creates the value resourcesApp which contains information on the
+-- resources declared below. This is used in Handler.hs by the call to
+-- mkYesodDispatch
+--
+-- What this function does *not* do is create a YesodSite instance for
+-- App. Creating that instance requires all of the handler functions
+-- for our application to be in scope. However, the handler functions
+-- usually require access to the AppRoute datatype. Therefore, we
+-- 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)
+
+-- Please see the documentation for the Yesod typeclass. There are a number
+-- of settings which can be configured by overriding methods here.
+instance Yesod App where
+ approot = ApprootMaster $ appRoot . settings
+
+ {-
+ -- 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
+ -}
+
+ defaultLayout widget = do
+ master <- getYesod
+ mmsg <- getMessage
+
+ -- We break up the default layout into two components:
+ -- default-layout is the contents of the body tag, and
+ -- default-layout-wrapper is the entire page. Since the final
+ -- value passed to hamletToRepHtml cannot be a widget, this allows
+ -- you to use normal widget features in default-layout.
+
+ pc <- widgetToPageContent $ do
+ $(widgetFile "default-layout")
+ hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+ -- This is done to provide an optimization for serving static files from
+ -- a separate domain. Please see the staticRoot setting in Settings.hs
+ urlRenderOverride y (StaticR s) =
+ Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
+ urlRenderOverride _ _ = Nothing
+
+ -- The page to be redirected to when authentication is required.
+ --authRoute _ = Just $ AuthR LoginR
+
+ messageLogger y loc level msg =
+ formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)
+
+ -- This function creates static content files in the static folder
+ -- and names them based on a hash of their content. This allows
+ -- expiration dates to be set far in the future without worry of
+ -- users receiving stale content.
+ addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
+
+ -- Place Javascript at bottom of the body tag so the rest of the page loads first
+ jsLoader _ = BottomOfBody
+
+-- How to run database actions.
+withDB :: (PostgreSQL.Connection -> IO a) -> Handler a
+withDB f = do
+ pool <- dbPool <$> getYesod
+ -- TODO: use takeResourceCheck, catch f
+ db <- takeResource pool
+ a <- lift $ lift $
+ f $ mrValue db
+ mrReuse db True
+ mrRelease db
+ return a
+
+
+-- This instance is required to use forms. You can modify renderMessage to
+-- achieve customized and internationalized form validation messages.
+instance RenderMessage App FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
+-- Note: previous versions of the scaffolding included a deliver function to
+-- send emails. Unfortunately, there are too many different options for us to
+-- give a reasonable default. Instead, the information is available on the
+-- wiki:
+--
+-- https://github.com/yesodweb/yesod/wiki/Sending-email
@@ -0,0 +1,96 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.Browse where
+
+import qualified Data.Text as T
+import Data.Maybe
+import Data.Time.Format
+import System.Locale
+
+import qualified Model
+import Import
+
+
+getNewR :: Handler RepHtml
+getNewR = do
+ downloads <- withDB $
+ Model.recentDownloads 50
+ defaultLayout $ do
+ setTitle "Bitlove: New Torrents"
+ toWidget [hamlet|
+<h2>New Torrents</h2>
+^{renderDownloads downloads}
+|]
+
+getTopR :: Handler RepHtml
+getTopR = do
+ downloads <- withDB $
+ Model.popularDownloads 25
+ defaultLayout $ do
+ setTitle "Bitlove: Popular Torrents"
+ toWidget [hamlet|
+<h2>Popular Torrents</h2>
+^{renderDownloads downloads}
+|]
+
+getTopDownloadedR :: Period -> Handler RepHtml
+getTopDownloadedR period = do
+ let (p, period_days) =
+ case period of
+ PeriodDays 1 -> (1, "1 day")
+ PeriodDays days -> (days, show days ++ " days")
+ PeriodAll -> (10000, "all time")
+ downloads <- withDB $
+ Model.mostDownloaded 10 p
+ lift $ lift $ putStrLn $ "render " ++ (show $ length downloads) ++ " downloads"
+ defaultLayout $ do
+ setTitle "Bitlove: Top Downloaded"
+ toWidget [hamlet|
+^{renderDownloads downloads}
+|]
+
+renderDownloads downloads =
+ let formatDate = formatTime defaultTimeLocale (iso8601DateFormat Nothing ++ " %H:%M") .
+ downloadPublished
+ in [hamlet|
+$forall d <- downloads
+ <article class="item">
+ <div>
+ $if not (T.null $ downloadImage d)
+ <img src="" class="logo">
+ <div class="right">
+ <p class="published">#{formatDate d}
+ <div class="flattr">
+ <div class="title">
+ <h3>
+ <a href="">#{downloadTitle d}
+ <p class="feed">
+ \ in #
+ <a href="">#{fromMaybe T.empty $ downloadFeedTitle d}
+ \ by #
+ <a href="">#{downloadUser d}
+ <ul class="download">
+ <li class="torrent">
+ <a href="" rel="enclosure" data-type=#{downloadType d}>
+ #{downloadName d} #
+ <span class="size" title="Download size">
+ #{humanSize (downloadSize d)}
+ <li class="stats">
+ <dl class="seeders">
+ <dt>#{downloadSeeders d}
+ <dd>Seeders
+ <dl class="leechers">
+ <dt>#{downloadLeechers d}
+ <dd>Leechers
+ <dl class="downloads">
+ <dt>#{downloadDownloaded d}
+ <dd>Downloads
+|]
+
+humanSize = humanSize' "KMGT" ""
+ where humanSize' units unit n
+ | n < 1024 || null units =
+ show n ++ " " ++ unit ++ "B"
+ | otherwise =
+ let (unit':units') = units
+ in humanSize' units' [unit'] $ n `div` 1024
+
Oops, something went wrong.

0 comments on commit cd96e18

Please sign in to comment.