Permalink
Browse files

Merge remote-tracking branch 'jannschu/style-update'

Conflicts:
	Handler/Browse.hs
	Handler/Thumbnails.hs
	Model/ImageCache.hs
	README.md
	static/style.css
  • Loading branch information...
2 parents 2146a3e + 9aaa650 commit f8d3258a5b5ca6907af084acb1642657cd628783 @astro committed Oct 8, 2012
Showing with 1,767 additions and 711 deletions.
  1. +1 −0 .gitignore
  2. +14 −4 Application.hs
  3. +4 −4 BitloveAuth.hs
  4. +17 −16 Foundation.hs
  5. +7 −7 Handler/Auth.hs
  6. +180 −156 Handler/Browse.hs
  7. +9 −9 Handler/Directory.hs
  8. +3 −2 Handler/DownloadFeeds.hs
  9. +2 −2 Handler/Edit.hs
  10. +9 −2 Handler/Help.hs
  11. +3 −0 Handler/Tracker.hs
  12. +4 −0 Handler/Widget.hs
  13. +9 −10 Model.hs
  14. +1 −0 Model/Feed.hs
  15. +4 −4 Model/ImageCache.hs
  16. +1 −2 Model/Query.hs
  17. +0 −1 Model/Tracker.hs
  18. +1 −0 PathPieces.hs
  19. +8 −15 README.md
  20. +15 −4 Settings.hs
  21. +4 −4 Stats.hs
  22. +3 −2 Utils.hs
  23. +1 −2 WorkQueue.hs
  24. +26 −0 devel.hs
  25. +8 −5 messages/de.msg
  26. +4 −1 messages/en.msg
  27. +0 −10 pg_imagecache.sql
  28. +306 −0 static/font-awesome.css
  29. BIN static/fonts/PatuaOne-Regular-webfont.eot
  30. +164 −0 static/fonts/PatuaOne-Regular-webfont.svg
  31. BIN static/fonts/PatuaOne-Regular-webfont.ttf
  32. BIN static/fonts/PatuaOne-Regular-webfont.woff
  33. BIN static/fonts/fontawesome-webfont.eot
  34. +255 −0 static/fonts/fontawesome-webfont.svg
  35. BIN static/fonts/fontawesome-webfont.ttf
  36. BIN static/fonts/fontawesome-webfont.woff
  37. BIN static/header_logo.png
  38. 0 static/{ → js}/activate.js
  39. 0 static/{ → js}/edit-feed.js
  40. 0 static/{ → js}/edit-user.js
  41. +13 −3 static/{ → js}/filter.js
  42. +2 −2 static/{ → js}/graphs.js
  43. 0 static/{ → js}/jquery-1.7.1.min.js
  44. 0 static/{ → js}/jquery.flot.js
  45. 0 static/{ → js}/jsSHA.js
  46. 0 static/{ → js}/login.js
  47. 0 static/{ → js}/signup.js
  48. +583 −391 static/style.css
  49. +7 −0 static/submenuglue.svg
  50. +4 −3 templates/activate.hamlet
  51. +2 −0 templates/default-layout-wrapper.hamlet
  52. +54 −30 templates/default-layout.hamlet
  53. +26 −15 templates/front.hamlet
  54. +1 −0 templates/help-api.hamlet
  55. +1 −0 templates/help-feeds.hamlet
  56. +1 −0 templates/help-podcaster.hamlet
  57. +1 −0 templates/help-widget.hamlet
  58. +1 −0 templates/help.hamlet
  59. +4 −3 templates/login.hamlet
  60. +1 −0 templates/reactivate.hamlet
  61. +3 −2 templates/signup.hamlet
View
@@ -0,0 +1 @@
+dist/
View
@@ -1,6 +1,7 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}
module Application
( makeApplication
+ , getApplicationDev
, makeUIFoundation
) where
@@ -21,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
import Control.Monad.Trans.Resource (register)
@@ -48,6 +49,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 +95,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 +106,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 =
@@ -129,6 +131,14 @@ makeApplication conf = do
]
return $ res'
+getApplicationDev :: IO (Int, Application)
+getApplicationDev =
+ defaultDevelApp loader makeApplication
+ where
+ loader = loadConfig (configSettings Settings.Development)
+ { csParseExtra = parseExtra
+ }
+
makeUIFoundation :: AppConfig BitloveEnv Extra -> DBPool -> IO UIApp
makeUIFoundation conf pool = do
manager <- newManager def
View
@@ -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
@@ -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
@@ -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.
|]
Oops, something went wrong.

0 comments on commit f8d3258

Please sign in to comment.