Browse files

fix warnings, move js files to /js, README update

1 parent fa29485 commit a931ff412306d7ed83062b9b7beec10572bed730 Jannik Schürg committed Aug 27, 2012
View
9 Application.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}
module Application
( makeApplication
, getApplicationDev
@@ -22,7 +22,7 @@ import Network.HTTP.Types (Status (Status, statusCode))
import System.CPUTime (getCPUTime)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import qualified Data.ByteString.Char8 as BC
-import Data.Monoid
+--import Data.Monoid
import System.IO (hPutStrLn, stderr)
import Network.Wai.Middleware.Autohead
@@ -48,6 +48,7 @@ import Stats
-- 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.
+-- TODO: remove -fno-warn-name-shadowing
mkYesodDispatch "UIApp" resourcesUIApp
-- This function allocates resources (such as a database connection pool),
@@ -93,7 +94,7 @@ makeApplication conf = do
enforceVhost :: Wai.Middleware
enforceVhost app req =
let proceed = app req
- redirect location = return $
+ getRedirectResponse location = return $
Wai.ResponseBuilder (Status 301 "Wrong vhost")
[("Location", location)]
mempty
@@ -104,7 +105,7 @@ makeApplication conf = do
| any (`BC.isPrefixOf` vhost) ["localhost", "bitlove.org", "api.bitlove.org"] ->
proceed
Just _ ->
- redirect $
+ getRedirectResponse $
"http://bitlove.org" `BC.append` Wai.rawPathInfo req
measureDuration :: Wai.Middleware
measureDuration app req =
View
8 BitloveAuth.hs
@@ -45,8 +45,8 @@ sessionBackend withDB =
mSidCookie
| otherwise =
Nothing
- session :: IO BackendSession
- session =
+ getBackendSession :: IO BackendSession
+ getBackendSession =
case mSid of
Nothing ->
return []
@@ -59,7 +59,7 @@ sessionBackend withDB =
_ ->
[]
- oldSession <- session
+ oldSession <- getBackendSession
let saveSession :: BackendSession -> time -> IO [Header]
saveSession newSession _time =
let mOldUser = "user" `lookup` oldSession
@@ -81,7 +81,7 @@ sessionBackend withDB =
session
}]
-- Logout
- (Just user, Nothing) ->
+ (Just _user, Nothing) ->
do case mSid of
Just sid ->
withDB $ invalidateSession sid
View
33 Foundation.hs
@@ -22,7 +22,6 @@ import Prelude
import System.IO (stderr, hPrint)
import Yesod
import Yesod.Static
-import Control.Monad (forM_)
import Control.Monad.Trans.Resource
--import Yesod.Auth
import Yesod.Default.Config
@@ -37,11 +36,12 @@ import Control.Applicative
import Data.Conduit.Pool
import qualified Database.HDBC as HDBC (withTransaction)
import qualified Database.HDBC.PostgreSQL as PostgreSQL (Connection)
+import Settings.StaticFiles
import Data.Text (Text)
import qualified Data.Text as T
import qualified Control.Exception as E
import qualified Network.Wai as Wai
-import qualified Data.ByteString.Char8 as BC
+import Data.ByteString.Char8 (isInfixOf)
import PathPieces
import BitloveAuth
@@ -124,8 +124,9 @@ instance Yesod UIApp where
-- you to use normal widget features in default-layout.
pc <- widgetToPageContent $ do
- forM_ ["jquery-1.7.1.min.js", "jquery.flot.js", "graphs.js"] $
- addScript . StaticR . flip StaticRoute [] . (:[])
+ addScript $ StaticR js_jquery_1_7_1_min_js
+ addScript $ StaticR js_jquery_flot_js
+ addScript $ StaticR js_graphs_js
addScriptRemote "https://api.flattr.com/js/0.6/load.js?mode=auto&popout=0&button=compact"
$(widgetFile "default-layout")
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
@@ -139,7 +140,7 @@ instance Yesod UIApp where
-- The page to be redirected to when authentication is required.
--authRoute _ = Just $ AuthR LoginR
- messageLogger y loc level msg _ =
+ messageLogger _y _loc _level _msg _ =
return ()
--formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)
@@ -177,22 +178,22 @@ authorizeFor user = do
-- We want full http://host URLs only in a few cases (feeds, API)
getFullUrlRender :: GHandler sub UIApp (Route UIApp -> Text)
getFullUrlRender =
- do approot <- appRoot <$> settings <$> getYesod
- ((approot `T.append`) .) <$> getUrlRender
+ do approot' <- appRoot <$> settings <$> getYesod
+ (T.append approot' .) <$> getUrlRender
isMiro :: GHandler sub master Bool
-isMiro =
- maybe False (maybe False (const True) .
- BC.findSubstring "Miro/") <$>
- lookup "User-Agent" <$>
- Wai.requestHeaders <$>
- waiRequest
+isMiro = let
+ userAgent = lookup "User-Agent" <$> Wai.requestHeaders <$> waiRequest
+ in maybe False (isInfixOf "Miro/") <$> userAgent
+
+errorHandler' :: forall sub.
+ ErrorResponse -> GHandler sub UIApp ChooseRep
errorHandler' NotFound =
fmap chooseRep $ defaultLayout $ do
setTitle "Bitlove: Not found"
let img = StaticR $ StaticRoute ["404.jpg"] []
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<article>
<h2>Not Found
<img src="@{img}">
@@ -201,15 +202,15 @@ errorHandler' NotFound =
errorHandler' (PermissionDenied _) =
fmap chooseRep $ defaultLayout $ do
setTitle "Bitlove: Permission denied"
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Permission denied
|]
errorHandler' e = do
liftIO $ hPrint stderr e
fmap chooseRep $ defaultLayout $
do setTitle "Bitlove: Error"
let img = StaticR $ StaticRoute ["500.jpg"] []
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<article>
<h2>Oops
<img src="@{img}">
View
14 Handler/Auth.hs
@@ -93,15 +93,15 @@ Thanks for sharing
True ->
defaultLayout $ do
setTitleI MsgTitleSignup
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Account activation pending
<p>Please check your mail to activate your account.
|]
False ->
-- TODO: unregister & rm token
defaultLayout $ do
setTitleI MsgTitleError
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Sorry
<p>Sending mail failed. Please #
<a href="mailto:mail@bitlove.org">contact support!
@@ -116,7 +116,7 @@ Thanks for sharing
sendError :: Text -> Handler a
sendError e = defaultLayout (do
setTitleI MsgTitleError
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Error
<p>#{e}
<p>
@@ -202,7 +202,7 @@ getActivateR token = do
Nothing ->
defaultLayout $ do
setTitleI MsgTitleError
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Error
<p>Invalid activation token
|]
@@ -283,18 +283,18 @@ Thanks for sharing
setTitleI MsgTitleReactivate
case sent of
_ | null userTokens ->
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Error
<p>No user with that email address was found.
|]
False ->
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Sorry
<p>Sending mail failed. Please #
<a href="mailto:mail@bitlove.org">contact support!
|]
True ->
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Account activation pending
<p>Please check your mail to activate your account.
|]
View
304 Handler/Browse.hs
@@ -3,14 +3,17 @@ module Handler.Browse where
import qualified Data.Text as T
import Data.Maybe
+import Data.Foldable (Foldable)
import Data.Time.Format
import System.Locale
import Network.HTTP.Types (parseQueryText)
import Text.Blaze
+import Text.Blaze.Internal (MarkupM)
import Text.Blaze.Html5 hiding (div, details, map)
import Text.Blaze.Html5.Attributes hiding (item, min, max, id)
import qualified Data.ByteString.Char8 as BC
import Control.Monad
+import Settings.StaticFiles
import PathPieces
import qualified Model
@@ -22,11 +25,12 @@ data Page = Page { pageNumber :: Int
, pageNext :: Maybe Text
}
+pageSize :: Int
pageSize = 30
withPage :: Page -> (Model.QueryPage -> a) -> a
-withPage p f =
- f $ Model.QueryPage pageSize $ (pageNumber p - 1) * pageSize
+withPage page f =
+ f $ Model.QueryPage pageSize $ (pageNumber page - 1) * pageSize
getFrontR :: Handler RepHtml
@@ -36,7 +40,7 @@ getFrontR = do
defaultLayout $ do
setTitleI MsgTitle
$(whamletFile "templates/front.hamlet")
- [whamlet|
+ [whamlet|$newline always
<section class="col2">
^{renderDownloads downloads True}
|]
@@ -50,17 +54,19 @@ getNewR = do
defaultLayout $ do
setTitleI MsgTitleNew
addFilterScript
- let links = [("Downloads", [("RSS", NewRssR, BC.unpack typeRss),
+ let
+ links :: [(Text, [(Text, Route UIApp, String)])]
+ links = [("Downloads", [("RSS", NewRssR, BC.unpack typeRss),
("ATOM", NewAtomR, BC.unpack typeAtom)
])]
addFeedsLinks links
- [whamlet|
-<section class="col">
- <h2>_{MsgNewTorrents}
- ^{renderFeedsList links}
- ^{renderDownloads downloads True}
- ^{renderPagination page}
-|]
+ [whamlet|$newline always
+ <section class="col">
+ <h2>_{MsgNewTorrents}
+ ^{renderFeedsList links}
+ ^{renderDownloads downloads True}
+ ^{renderPagination page}
+ |]
getTopR :: Handler RepHtml
getTopR = do
@@ -71,17 +77,19 @@ getTopR = do
defaultLayout $ do
setTitleI MsgTitleTop
addFilterScript
- let links = [("Downloads", [("RSS", TopRssR, BC.unpack typeRss),
+ let
+ links :: [(Text, [(Text, Route UIApp, String)])]
+ links = [("Downloads", [("RSS", TopRssR, BC.unpack typeRss),
("ATOM", TopAtomR, BC.unpack typeAtom)
])]
addFeedsLinks links
- [whamlet|
-<section class="col">
- <h2>_{MsgTopTorrents}
- ^{renderFeedsList links}
- ^{renderDownloads downloads True}
- ^{renderPagination page}
-|]
+ [whamlet|$newline always
+ <section class="col">
+ <h2>_{MsgTopTorrents}
+ ^{renderFeedsList links}
+ ^{renderDownloads downloads True}
+ ^{renderPagination page}
+ |]
getTopDownloadedR :: Period -> Handler RepHtml
getTopDownloadedR period = do
@@ -102,21 +110,21 @@ getTopDownloadedR period = do
("ATOM", TopDownloadedAtomR period, BC.unpack typeAtom)
])]
addFeedsLinks links
- [whamlet|
-<section class="col">
- <h2>
- $case period
- $of PeriodDays n
- $if n == 1
- \ _{MsgTopDownloadedDay}
- $else
- \ _{MsgTopDownloadedDays n}
- $of PeriodAll
- \ _{MsgTopDownloadedAll}
- ^{renderFeedsList links}
- ^{renderDownloads downloads True}
- ^{renderPagination page}
-|]
+ [whamlet|$newline always
+ <section class="col">
+ <h2>
+ $case period
+ $of PeriodDays n
+ $if n == 1
+ \ _{MsgTopDownloadedDay}
+ $else
+ \ _{MsgTopDownloadedDays n}
+ $of PeriodAll
+ \ _{MsgTopDownloadedAll}
+ ^{renderFeedsList links}
+ ^{renderDownloads downloads True}
+ ^{renderPagination page}
+ |]
getUserR :: UserName -> Handler RepHtml
getUserR user = do
@@ -136,45 +144,45 @@ getUserR user = do
defaultLayout $ do
setTitleI $ MsgTitleUser $ userName user
when canEdit' $
- addScript $ StaticR $ StaticRoute ["edit-user.js"] []
+ addScript $ StaticR js_edit_user_js
let links = [("Downloads", [("RSS", UserDownloadsRssR user, BC.unpack typeRss),
("ATOM", UserDownloadsAtomR user, BC.unpack typeAtom)
])]
addFeedsLinks links
- [whamlet|
-<header class="user">
- <div class="meta">
- $if not (T.null $ userImage details)
- <img class="logo"
- src=@{UserThumbnailR user (Thumbnail 64)}>
- <div class="title">
- <h2>#{userTitle details}
- $if not (T.null $ userHomepage details)
- <p class="homepage">
- <a rel="me"
- href=#{userHomepage details}>#{userHomepage details}
-<section class="col1">
- <h2>Feeds
- $forall feed <- feeds
- <article class="feed">
- <img class="logo"
- src="@{UserFeedThumbnailR user (feedSlug feed) (Thumbnail 64)}">
- <div>
- <h3>
- <a href="@{UserFeedR user (feedSlug feed)}">#{feedTitle feed}
- $if not (T.null $ feedHomepage feed)
- <p class="homepage">
- <a rel="me"
- href="#{feedHomepage feed}">#{feedHomepage feed}
- $if not (feedPublic feed)
- <p .note>_{MsgPrivate}
-
-<section class="col2">
- <h2>Recent Torrents
- ^{renderFeedsList links}
- ^{renderDownloads downloads False}
- ^{renderPagination page}
- |]
+ [whamlet|$newline always
+ <header class="user">
+ <div class="meta">
+ $if not (T.null $ userImage details)
+ <img class="logo"
+ src=@{UserThumbnailR user (Thumbnail 64)}>
+ <div class="title">
+ <h2>#{userTitle details}
+ $if not (T.null $ userHomepage details)
+ <p class="homepage">
+ <a rel="me"
+ href=#{userHomepage details}>#{userHomepage details}
+ <section class="col1">
+ <h2>Feeds
+ $forall feed <- feeds
+ <article class="feed">
+ <img class="logo"
+ src="@{UserFeedThumbnailR user (feedSlug feed) (Thumbnail 64)}">
+ <div>
+ <h3>
+ <a href="@{UserFeedR user (feedSlug feed)}">#{feedTitle feed}
+ $if not (T.null $ feedHomepage feed)
+ <p class="homepage">
+ <a rel="me"
+ href="#{feedHomepage feed}">#{feedHomepage feed}
+ $if not (feedPublic feed)
+ <p .note>_{MsgPrivate}
+
+ <section class="col2">
+ <h2>Recent Torrents
+ ^{renderFeedsList links}
+ ^{renderDownloads downloads False}
+ ^{renderPagination page}
+ |]
fetch >>= maybe notFound render
@@ -192,16 +200,16 @@ getUserFeedR user slug = do
(feed:_) ->
do downloads <-
withPage page (Model.feedDownloads $ feedUrl feed) db
- enclosureErrors <-
+ enclosureErrs <-
if canEdit'
then Model.enclosureErrors (feedUrl feed) db
else return []
- return $ Just (feed, downloads, enclosureErrors)
+ return $ Just (feed, downloads, enclosureErrs)
case mFeedDownloadsErrors of
Nothing ->
notFound
- Just (feed, downloads, enclosureErrors) ->
+ Just (feed, downloads, enclosureErrs) ->
do let links = [("Subscribe",
[("Feed", MapFeedR user slug, BC.unpack typeRss)]),
("Just Downloads",
@@ -216,56 +224,58 @@ getUserFeedR user slug = do
defaultLayout $
do setTitleI $ MsgTitleFeed $ feedTitle feed
when canEdit' $
- addScript $ StaticR $ StaticRoute ["edit-feed.js"] []
+ addScript $ StaticR js_edit_feed_js
addFeedsLinks links
- [whamlet|
-<section class="col">
- <header class="feed">
- <div class="meta">
- <img class="logo"
- src="@{UserFeedThumbnailR user slug (Thumbnail 64)}">
- <div class="title">
- <div>
- <h2>#{feedTitle feed}
- <span class="publisher">
- \ _{MsgBy} #
- <a href="@{UserR user}">#{userName user}
- $if not (T.null $ feedHomepage feed)
- <p class="homepage">
- <a rel="me"
- href="#{feedHomepage feed}">#{feedHomepage feed}
- $if not (feedPublic feed)
- <p class="hint">_{MsgPrivateExplain}
- $maybe error <- mError
- <div class="error">
- <h3>Feed Error
- <p><pre>#{error}
- <p .hint>_{MsgErrorExplain}
-
- $if not (null enclosureErrors)
- <div .error>
- <h3>_{MsgEnclosureErrors}
- <dl .enclosureErrors>
- $forall enclosureError <- enclosureErrors
- <dt>#{fst enclosureError}
- <dd><pre>#{snd enclosureError}
- ^{renderFeedsList links}
- ^{renderDownloads downloads False}
- ^{renderPagination page}
- |]
+ [whamlet|$newline always
+ <section class="col">
+ <header class="feed">
+ <div class="meta">
+ <img class="logo"
+ src="@{UserFeedThumbnailR user slug (Thumbnail 64)}">
+ <div class="title">
+ <div>
+ <h2>#{feedTitle feed}
+ <span class="publisher">
+ \ _{MsgBy} #
+ <a href="@{UserR user}">#{userName user}
+ $if not (T.null $ feedHomepage feed)
+ <p class="homepage">
+ <a rel="me"
+ href="#{feedHomepage feed}">#{feedHomepage feed}
+ $if not (feedPublic feed)
+ <p class="hint">_{MsgPrivateExplain}
+ $maybe err <- mError
+ <div class="error">
+ <h3>Feed Error
+ <p><pre>#{err}
+ <p .hint>_{MsgErrorExplain}
+
+ $if not (null enclosureErrs)
+ <div .error>
+ <h3>_{MsgEnclosureErrors}
+ <dl .enclosureErrors>
+ $forall enclosureError <- enclosureErrs
+ <dt>#{fst enclosureError}
+ <dd><pre>#{snd enclosureError}
+ ^{renderFeedsList links}
+ ^{renderDownloads downloads False}
+ ^{renderPagination page}
+ |]
+renderDownloads :: forall sub. [Download] -> Bool -> GWidget sub UIApp ()
renderDownloads downloads showOrigin =
- [whamlet|
-$forall item <- Model.groupDownloads downloads
- ^{renderItem item showOrigin}
- |]
+ [whamlet|$newline always
+ $forall item <- Model.groupDownloads downloads
+ ^{renderItem item showOrigin}
+ |]
+renderItem :: forall sub. Item -> Bool -> GWidget sub UIApp ()
renderItem item showOrigin = do
let date = formatTime defaultTimeLocale (iso8601DateFormat Nothing ++ "\n%H:%M") $
itemPublished item
- isOnlyDownload = length (itemDownloads item) == 1
+ --isOnlyDownload = length (itemDownloads item) == 1
stats :: Text -> Text -> Integer -> t -> Markup
- stats c t n = [hamlet|
+ stats c t n = [hamlet|$newline always
<dl class=#{c}>
<dt>
#{n}
@@ -284,15 +294,15 @@ renderItem item showOrigin = do
downloadDownspeed d
n' :: String
n' | n < 10 =
- show (fromIntegral (truncate $ n * 10) / 10 :: Double)
+ show (fromIntegral (truncate $ n * 10 :: Integer) / 10 :: Double)
| otherwise =
- show $ truncate n
+ show $ (truncate n :: Integer)
in (n', unit ++ "B/s")
seeders = (+ 1) . downloadSeeders
types = map downloadType $ itemDownloads item
countType t = length $ filter (== t) types
isOnlyType = (== 1) . countType
- [whamlet|
+ [whamlet|$newline always
<article class="item"
id="#{itemId item}"
xml:lang="#{fromMaybe "" $ itemLang item}">
@@ -390,23 +400,30 @@ renderItem item showOrigin = do
! href (toValue payment) $
"[Support]"
+addFilterScript :: forall sub. GWidget sub UIApp ()
addFilterScript =
- addScript $ StaticR $ StaticRoute ["filter.js"] []
+ addScript $ StaticR js_filter_js
-- | <link rel="alternate"> to <head>
+addFeedsLinks :: forall sub master a a1.
+ ToMarkup a =>
+ [(a1, [(Text, Route master, a)])] -> GWidget sub master ()
addFeedsLinks lists = do
- let addFeedsLink (title :: Text, route, type_) =
- [hamlet|
+ let addFeedsLink (linkTitle :: Text, route, linkType) =
+ [hamlet|$newline always
<link rel="alternate"
- type="#{type_}"
+ type="#{linkType}"
href="@{route}"
- title="#{title}">
+ title="#{linkTitle}">
|]
- addHamletHead [hamlet|
+ toWidgetHead [hamlet|$newline always
$forall feed <- concat $ map snd lists
^{addFeedsLink feed}
|]
+renderFeedsList :: forall a (t :: * -> *) sub (t1 :: * -> *).
+ (Foldable t1, Foldable t, ToMarkup a) =>
+ t1 (Text, t (Text, Route UIApp, a)) -> GWidget sub UIApp ()
renderFeedsList lists = do
renderRoute <-
lift $
@@ -416,37 +433,40 @@ renderFeedsList lists = do
then (("http://subscribe.getmiro.com/?type=video&url1=" `T.append`) <$>)
else id) <$>
getFullUrlRender
- let renderFeedsList' (title :: Text, feeds) =
- [hamlet|
- <dt>#{title}:
+ let renderFeedsList' (fTitle :: Text, feeds) =
+ [hamlet|$newline always
+ <dt>#{fTitle}:
$forall feed <- feeds
<dd>^{renderFeedsList'' feed}
|]
- renderFeedsList'' (title :: Text, route, type_) =
- [hamlet|
+ renderFeedsList'' (fTitle :: Text, route, fType) =
+ [hamlet|$newline always
<a href="#{renderRoute route}"
- type=#{type_}>#{title}
+ type=#{fType}>#{fTitle}
|]
- [whamlet|
+ [whamlet|$newline always
<dl class="feedslist">
- $forall list <- lists
- ^{renderFeedsList' list}
+ $forall fList <- lists
+ ^{renderFeedsList' fList}
|]
pageParameter :: Handler Int
pageParameter = (clamp . fromInt 1 . T.unpack . fromMaybe "") <$>
lookupGetParam "page"
where fromInt d s =
case reads s of
- [(i, "")] -> i
+ [(j, "")] -> j
_ -> d
clamp = min maxPages .
max 1
-
+
+maxPages :: Int
maxPages = 10
-
+
+
+renderPagination :: forall t. Page -> t -> MarkupM ()
renderPagination page =
- [hamlet|
+ [hamlet|$newline always
<nav .pagination>
$maybe previous <- pagePrevious page
<p .previous>
@@ -458,7 +478,7 @@ renderPagination page =
makePage :: Handler Page
makePage = do
- p <- pageParameter
+ pageParam <- pageParameter
url <- getUrlRender
mRoute <- getCurrentRoute
let pageLink p' =
@@ -472,16 +492,16 @@ makePage = do
| otherwise =
Just n
return $
- Page { pageNumber = p
- , pagePrevious = clamp (p - 1) >>= pageLink
- , pageNext = clamp (p + 1) >>= pageLink
+ Page { pageNumber = pageParam
+ , pagePrevious = clamp (pageParam - 1) >>= pageLink
+ , pageNext = clamp (pageParam + 1) >>= pageLink
}
humanSize :: (Integral a, Show a) => a -> String
humanSize n = let (n', unit) = humanSize' $ fromIntegral n
ns | n' < 10 = show $
- fromIntegral (truncate $ n' * 10) / 10
- | otherwise = show $ truncate n'
+ (fromIntegral (truncate $ n' * 10 :: Integer) / 10 :: Double)
+ | otherwise = show $ (truncate n' :: Integer)
in ns ++ " " ++ unit ++ "B"
humanSize' :: Double -> (Double, String)
View
10 Handler/Directory.hs
@@ -15,9 +15,11 @@ getDirectoryR = do
let (dir1, dir2) = splitAt ((length dir + 1) `div` 2) dir
defaultLayout $ do
setTitleI MsgTitleDirectory
- let links = [("Feeds", [("OPML", DirectoryOpmlR, BC.unpack typeOpml)])]
+ let
+ links :: [(Text, [(Text, Route UIApp, String)])]
+ links = [("Feeds", [("OPML", DirectoryOpmlR, BC.unpack typeOpml)])]
addFeedsLinks links
- [whamlet|
+ [whamlet|$newline always
<h2>_{MsgHeadingDirectory}
^{renderFeedsList links}
<section class="col1 directory">
@@ -26,7 +28,7 @@ getDirectoryR = do
^{renderEntries dir2}
|]
where renderEntries entries =
- [hamlet|
+ [hamlet|$newline always
$forall es <- entries
<article class="meta">
<img class="logo"
@@ -57,7 +59,7 @@ getDirectoryOpmlR = do
dir <- groupDirectory `fmap` withDB (Model.getDirectory)
url <- getFullUrlRender
RepOpml `fmap`
- hamletToContent [xhamlet|
+ hamletToContent [xhamlet|$newline always
<opml version="2.0">
<head title="Bitlove.org directory"
ownerId="#{url DirectoryR}">
View
5 Handler/DownloadFeeds.hs
@@ -53,7 +53,7 @@ instance RepFeed RepRss where
renderFeed params items = do
url <- getFullUrlRender
let image = pImage params
- RepRss `fmap` hamletToContent [xhamlet|
+ RepRss `fmap` hamletToContent [xhamlet|$newline always
<rss version="2.0"
xmlns:atom=#{nsAtom}>
<channel>
@@ -96,7 +96,7 @@ instance RepFeed RepAtom where
let image = pImage params
url <- getFullUrlRender
tz <- liftIO getCurrentTimeZone
- RepAtom `fmap` hamletToContent [xhamlet|
+ RepAtom `fmap` hamletToContent [xhamlet|$newline always
<feed version="1.0"
xmlns=#{nsAtom}>
<title>#{pTitle params}
@@ -137,6 +137,7 @@ instance RepFeed RepAtom where
>
|]
+itemLink :: (Route UIApp -> Text) -> Item -> Text
itemLink urlRender item =
urlRender (UserFeedR (itemUser item) (itemSlug item)) `T.append`
"#" `T.append`
View
4 Handler/Edit.hs
@@ -58,12 +58,12 @@ putUserFeedR user slug = do
returnJson ["link" .= link]
where validateSlug :: Text -> Bool
- validateSlug slug = T.length slug >= 1 &&
+ validateSlug slg = T.length slg >= 1 &&
all (\c ->
isAsciiLower c ||
isDigit c ||
c `elem` "-_"
- ) (T.unpack slug)
+ ) (T.unpack slg)
deleteUserFeedR :: UserName -> Text -> Handler RepJson
deleteUserFeedR user slug = do
View
11 Handler/Help.hs
@@ -6,26 +6,30 @@ import qualified Data.Text as T
import Import
+getHelpR :: GHandler sub UIApp RepHtml
getHelpR =
defaultLayout $ do
setTitleI MsgTitleHelp
renderHelpNavigation
$(whamletFile "templates/help.hamlet")
+getHelpPodcasterR :: GHandler sub UIApp RepHtml
getHelpPodcasterR =
defaultLayout $ do
setTitleI MsgTitleHelp
renderHelpNavigation
renderHelpPodcasterNavigation
$(whamletFile "templates/help-podcaster.hamlet")
+getHelpFeedsR :: GHandler sub UIApp RepHtml
getHelpFeedsR =
defaultLayout $ do
setTitleI MsgTitleHelp
renderHelpNavigation
renderHelpPodcasterNavigation
$(whamletFile "templates/help-feeds.hamlet")
+getHelpApiR :: GHandler sub UIApp RepHtml
getHelpApiR =
defaultLayout $ do
setTitleI MsgTitleHelp
@@ -35,6 +39,7 @@ getHelpApiR =
BC.unpack $(embedFile "templates/help-api-example.text")
$(whamletFile "templates/help-api.hamlet")
+getHelpWidgetR :: GHandler sub UIApp RepHtml
getHelpWidgetR =
defaultLayout $ do
setTitleI MsgTitleHelp
@@ -44,8 +49,9 @@ getHelpWidgetR =
BC.unpack $(embedFile "templates/help-widget-example.text")
$(whamletFile "templates/help-widget.hamlet")
+renderHelpNavigation :: GWidget sub UIApp ()
renderHelpNavigation =
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Help
<div class="navtabs">
<ul>
@@ -55,8 +61,9 @@ renderHelpNavigation =
<a href="@{HelpPodcasterR}">Podcasters</a>
|]
+renderHelpPodcasterNavigation :: GWidget sub UIApp ()
renderHelpPodcasterNavigation =
- toWidget [hamlet|
+ toWidget [hamlet|$newline always
<h2>Help for Podcasters</h2>
<div class="navtabs">
<ul>
View
1 Handler/Thumbnails.hs
@@ -5,7 +5,6 @@ import Data.Conduit
import Network.HTTP.Conduit
import System.Process.QQ
import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
import Network.HTTP.Types (statusCode)
import qualified Data.Conduit.List as CL
View
3 Handler/Tracker.hs
@@ -23,7 +23,10 @@ import qualified WorkQueue as WQ
-- TODO: make configurable
+ourPeerId :: PeerId
ourPeerId = PeerId "-<30000-bitlove.org/"
+
+ourSeeders :: [TrackedPeer]
ourSeeders = do
addr <- [ Peer4 "\85\10\246\236"
, Peer6 "\x2a\x01\x04\xf8\x01\x60\x54\x21\x00\x00\x00\x00\x00\x00\x00\x03"
View
3 Handler/Widget.hs
@@ -3,6 +3,7 @@ module Handler.Widget where
import Prelude
import Data.FileEmbed (embedFile)
import Blaze.ByteString.Builder (fromByteString)
+import Blaze.ByteString.Builder.Internal.Types (Builder)
import Data.Monoid
import Import
@@ -15,8 +16,10 @@ newtype RepJs = RepJs Content
instance HasReps RepJs where
chooseRep (RepJs content) _ = return (typeJavascript, content)
+serveJs :: Monad m => Builder -> m RepJs
serveJs = return . RepJs . flip ContentBuilder Nothing
+wrapJs :: Builder -> Builder
wrapJs js = mconcat
[ fromByteString "(function() { "
, js
View
19 Model.hs
@@ -63,7 +63,6 @@ import Prelude
import Data.Convertible
import Data.Text (Text)
import Database.HDBC
-import Data.Time
import Data.Data (Typeable)
import qualified Data.ByteString.Char8 as BC
import Control.Applicative
@@ -121,16 +120,16 @@ data DirectoryEntry = DirectoryEntry
} deriving (Show, Typeable)
instance Convertible [SqlValue] DirectoryEntry where
- safeConvert (user:userTitle:userImage:
- feedSlug:feedTitle:feedLang:feedTypes:[]) =
+ safeConvert (userVal:userTitleVal:userImageVal:
+ feedSlugVal:feedTitleVal:feedLangVal:feedTypesVal:[]) =
DirectoryEntry <$>
- safeFromSql user <*>
- safeFromSql userTitle <*>
- (fixUrl <$> safeFromSql userImage) <*>
- safeFromSql feedSlug <*>
- safeFromSql feedTitle <*>
- safeFromSql feedLang <*>
- safeFromSql feedTypes
+ safeFromSql userVal <*>
+ safeFromSql userTitleVal <*>
+ (fixUrl <$> safeFromSql userImageVal) <*>
+ safeFromSql feedSlugVal <*>
+ safeFromSql feedTitleVal <*>
+ safeFromSql feedLangVal <*>
+ safeFromSql feedTypesVal
safeConvert vals = convError "DirectoryEntry" vals
getDirectory :: Query DirectoryEntry
View
1 Model/Feed.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Feed where
import Prelude
View
8 Model/ImageCache.hs
@@ -13,11 +13,11 @@ data CachedImage = CachedImage B.ByteString
| CachedError String
instance Convertible [SqlValue] CachedImage where
- safeConvert [data_, error]
+ safeConvert [data_, err]
| not (B.null $ fromBytea data_) =
Right $ CachedImage $ fromBytea data_
| otherwise =
- Right $ CachedError $ fromSql error
+ Right $ CachedError $ fromSql err
safeConvert _ = Right $ CachedError "safeConvert CachedImage error"
getImage :: Text -> Int -> Query CachedImage
@@ -29,9 +29,9 @@ putImage :: IConnection conn =>
Text -> Int -> CachedImage -> conn -> IO ()
putImage url size cached db =
do 1 <- case cached of
- CachedError error ->
+ CachedError err ->
run db "INSERT INTO cached_images (\"url\", \"size\", \"error\", \"time\") VALUES (?, ?, ?, NOW())"
- [toSql url, toSql size, toSql error]
+ [toSql url, toSql size, toSql err]
CachedImage data_ ->
run db "INSERT INTO cached_images (\"url\", \"size\", \"data\", \"time\") VALUES (?, ?, ?, NOW())"
[toSql url, toSql size, toBytea data_]
View
3 Model/Query.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RankNTypes, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Query where
import Prelude
@@ -10,11 +11,9 @@ import Data.ByteString (ByteString, pack, unpack)
import qualified Data.ByteString.Char8 as BC
import Numeric (showOct, readOct)
import Data.Char (chr, ord)
-import Control.Monad (mapM)
import qualified Control.Exception as E
import System.IO
import Control.Applicative
-import Data.Either
import Data.Default
import Utils
View
1 Model/Tracker.hs
@@ -6,7 +6,6 @@ import Data.Convertible
import Data.Data (Typeable)
import Database.HDBC
import qualified Data.ByteString.Char8 as BC
-import Control.Monad (when)
import Control.Applicative
import Model.Query
View
1 PathPieces.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module PathPieces where
import Prelude
View
22 README.md
@@ -14,29 +14,23 @@ Some commands need to be adjusted or left off. Start the installation by running
pg_ctl -D /usr/local/var/postgres start
createdb prittorrent
-Next get the database setup sql files in your project folder:
+Next get the database dump in your project folder:
- wget https://raw.github.com/astro/prittorrent/master/pg_install.sql
- wget https://raw.github.com/astro/prittorrent/master/pg_meta.sql
- wget https://raw.github.com/astro/prittorrent/master/pg_var.sql
- wget https://raw.github.com/astro/prittorrent/master/pg_tracker.sql
- wget https://raw.github.com/astro/prittorrent/master/pg_downloads.sql
- wget https://raw.github.com/astro/prittorrent/master/pg_stats.sql
+ https://spaceboyz.net/~astro/prittorrent-2012-08-27.sql.bz2
+ bzip2 -d prittorrent-2012-08-27.sql.bz2
Open a shell with `psql prittorrent` and enter:
CREATE USER prittorrent WITH SUPERUSER PASSWORD '1234';
- \i pg_install.sql
- -- ignore the tablespace errors
- \i pg_imagecache.sql
+ CREATE ROLE postgres;
+ \i prittorrent-2012-08-27.sql
\q
- rm pg_!(imagecache).sql
+ rm prittorrent-2012-08-27.sql
Compile and run:
cabal update && cabal install --only-dependencies
- cabal configure && cabal build
- ./dist/build/ui/ui Development
+ yesod devel
Now point your browser to `http://localhost:8081/`.
@@ -71,4 +65,4 @@ Now point your browser to `http://localhost:8081/`.
* Fetch & display feed summaries
* Feed summaries: X items, Y torrents
* OEmbed
-* Installation: automation, sample data, fix database setup
+* Installation: automation
View
19 Settings.hs
@@ -16,12 +16,13 @@ import Prelude
import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
import Yesod.Default.Config
-import qualified Yesod.Default.Util
+import Yesod.Default.Util
import Data.Text (Text)
import Data.Yaml
import Control.Applicative
import Settings.Development
-import Data.Default
+import Data.Default (def)
+import Text.Hamlet
data BitloveEnv = Development
@@ -55,12 +56,22 @@ staticRoot :: AppConfig DefaultEnv x -> Text
staticRoot conf = [st|#{appRoot conf}/static|]
+-- | Settings for 'widgetFile', such as which template languages to support and
+-- default Hamlet settings.
+widgetFileSettings :: WidgetFileSettings
+widgetFileSettings = def
+ { wfsHamletSettings = defaultHamletSettings
+ { hamletNewlines = AlwaysNewlines
+ }
+ }
+
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
-widgetFile = if development then Yesod.Default.Util.widgetFileReload def
- else Yesod.Default.Util.widgetFileNoReload def
+widgetFile = (if development then widgetFileReload
+ else widgetFileNoReload)
+ widgetFileSettings
data Extra = Extra
{ extraCopyright :: Text
View
8 Stats.hs
@@ -59,7 +59,7 @@ increaseCounter pool tBuf key increment = do
return False
when isNew $ do
- forkIO $ do
+ _ <- forkIO $ do
threadDelay second
flushCounter pool tBuf key
return ()
@@ -79,10 +79,10 @@ flushCounter pool tBuf key = do
let (kind, info) = key
case increment of
- increment
- | increment > 0 ->
+ increment'
+ | increment' > 0 ->
runResourceT $
withDBPool pool $
- addCounter kind (InfoHash info) increment
+ addCounter kind (InfoHash info) increment'
_ ->
putStrLn $ "Warning: stale counter for " ++ show key
View
5 Utils.hs
@@ -53,11 +53,12 @@ fromHex = B.pack . hexToWords
-- FIXME: rm usage once feeds parser stores URLs properly
+fixUrl :: T.Text -> T.Text
fixUrl = unescapeEntities
unescapeEntities :: T.Text -> T.Text
-unescapeEntities t =
- case T.break (== '&') t of
+unescapeEntities text =
+ case T.break (== '&') text of
(t, "") ->
t
(t', t'') ->
View
3 WorkQueue.hs
@@ -2,7 +2,6 @@ module WorkQueue where
import Prelude
import Control.Concurrent
-import Control.Concurrent.Chan
import qualified Control.Exception as E
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
@@ -19,7 +18,7 @@ makeQueue = do
E.catch (runResourceT f) handleE
loop
- forkIO loop
+ _ <- forkIO loop
return $ Queue chan
enqueue :: Queue -> ResourceT IO () -> IO ()
View
10 pg_imagecache.sql
@@ -1,10 +0,0 @@
-SET default_tablespace = fast;
-
-CREATE TABLE cached_images (
- "url" TEXT NOT NULL,
- "size" INT NOT NULL,
- "time" TIMESTAMP,
- "error" TEXT,
- "data" BYTEA,
- PRIMARY KEY ("url", "size")
-);
View
0 static/activate.js → static/js/activate.js
File renamed without changes.
View
0 static/edit-feed.js → static/js/edit-feed.js
File renamed without changes.
View
0 static/edit-user.js → static/js/edit-user.js
File renamed without changes.
View
0 static/filter.js → static/js/filter.js
File renamed without changes.
View
0 static/graphs.js → static/js/graphs.js
File renamed without changes.
View
0 static/jquery-1.7.1.min.js → static/js/jquery-1.7.1.min.js
File renamed without changes.
View
0 static/jquery.flot.js → static/js/jquery.flot.js
File renamed without changes.
View
0 static/jsSHA.js → static/js/jsSHA.js
File renamed without changes.
View
0 static/login.js → static/js/login.js
File renamed without changes.
View
0 static/signup.js → static/js/signup.js
File renamed without changes.
View
7 templates/activate.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<noscript>_{MsgNoScript}
<form class="login r">
@@ -11,6 +12,6 @@
<p id="progress">
<input id="activate" type="submit" value="_{MsgActivate}"
data-token="#{hexToken}" data-salt="#{hexSalt}">
- <script src="/static/jquery-1.7.1.min.js" type="text/javascript">
- <script src="/static/jsSHA.js" type="text/javascript">
- <script src="/static/activate.js" type="text/javascript">
+ <script src="/static/js/jquery-1.7.1.min.js" type="text/javascript">
+ <script src="/static/js/jsSHA.js" type="text/javascript">
+ <script src="/static/js/activate.js" type="text/javascript">
View
1 templates/default-layout-wrapper.hamlet
@@ -1,3 +1,4 @@
+$newline always
$doctype 5
<html>
<head>
View
1 templates/front.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col1">
<p class="about">
_{MsgFrontAbout}
View
1 templates/help-api.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<h2>API</h2>
View
1 templates/help-feeds.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<h2>Feeds
View
1 templates/help-podcaster.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<h2>Getting started
<h3>What do I need to publish?
View
1 templates/help-widget.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<h2>Widgets
<p>We provide easy to use JavaScript snippets for browser-side integration. They use the API.
View
1 templates/help.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<h2>Help for Users
View
7 templates/login.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<noscript>_{MsgNoScript}
<form class="login r">
@@ -12,6 +13,6 @@
<input id="login" type="submit" value="Login">
<p>
<a href="@{ReactivateR}">_{MsgForgotPasswordQuestion}</a>
- <script src="/static/jquery-1.7.1.min.js" type="text/javascript">
- <script src="/static/jsSHA.js" type="text/javascript">
- <script src="/static/login.js" type="text/javascript">
+ <script src="/static/js/jquery-1.7.1.min.js" type="text/javascript">
+ <script src="/static/js/jsSHA.js" type="text/javascript">
+ <script src="/static/js/login.js" type="text/javascript">
View
1 templates/reactivate.hamlet
@@ -1,3 +1,4 @@
+$newline always
<section class="col">
<form class="login"
method="POST"
View
5 templates/signup.hamlet
@@ -1,3 +1,4 @@
+$newline always
<div class="content">
<section class="col1">
<noscript>_{MsgNoScript}</noscript>
@@ -19,8 +20,8 @@
<input type="checkbox" id="tos-2" name="tos-2" value="tos-2">
<label for="tos-2"> _{MsgTos2}
<input id="signup" type="submit" value="Signup">
- <script src="/static/jquery-1.7.1.min.js" type="text/javascript">
- <script src="/static/signup.js" type="text/javascript">
+ <script src="/static/js/jquery-1.7.1.min.js" type="text/javascript">
+ <script src="/static/js/signup.js" type="text/javascript">
<section class="col2">
<h2>_{MsgNoWarez}
<p>_{MsgNoWarezExplanation}

0 comments on commit a931ff4

Please sign in to comment.