Permalink
Browse files

updates for 1.0

  • Loading branch information...
1 parent cac70eb commit 58a27ecd7eca4b212b3bfe9e53fd3039a824bd64 @pbrisbin committed Apr 13, 2012
Showing with 69 additions and 71 deletions.
  1. +17 −14 Application.hs
  2. +10 −27 Foundation.hs
  3. +1 −0 Handler/Feed.hs
  4. +1 −0 Handler/Posts.hs
  5. +1 −1 Handler/Tags.hs
  6. +1 −0 Handler/Users.hs
  7. +1 −0 Helpers/Post.hs
  8. +9 −3 Import.hs
  9. +2 −2 Settings.hs
  10. +0 −1 config/devsite
  11. +24 −21 devsite.cabal
  12. +2 −2 main.hs
View
@@ -1,12 +1,11 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
- ( getApplication
+ ( makeApplication
, getApplicationDev
) where
import Import
import Settings
-import Settings.StaticFiles (staticSite)
import Yesod.Auth
import Yesod.Default.Config
import Yesod.Default.Main
@@ -45,17 +44,9 @@ mkYesodDispatch "DevSite" resourcesDevSite
-- 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.
-getApplication :: AppConfig DefaultEnv () -> Logger -> IO Application
-getApplication conf logger = do
- manager <- newManager def
- s <- staticSite
- dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
- Database.Persist.Store.loadConfig >>=
- Database.Persist.Store.applyEnv
- p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
- Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
- Database.Persist.Store.runPool dbconf (runMigration migrateComments) p
- let foundation = DevSite conf setLogger s p manager dbconf
+makeApplication :: AppConfig DefaultEnv () -> Logger -> IO Application
+makeApplication conf logger = do
+ foundation <- makeFoundation conf setLogger
app <- toWaiAppPlain foundation
return $ logWare app
where
@@ -67,9 +58,21 @@ getApplication conf logger = do
logWare = logCallback (logBS setLogger)
#endif
+makeFoundation :: AppConfig DefaultEnv () -> Logger -> IO DevSite
+makeFoundation conf setLogger = do
+ manager <- newManager def
+ s <- staticSite
+ dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
+ Database.Persist.Store.loadConfig >>=
+ Database.Persist.Store.applyEnv
+ p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
+ Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
+ Database.Persist.Store.runPool dbconf (runMigration migrateComments) p
+ return $ DevSite conf setLogger s p manager dbconf
+
-- for yesod devel
getApplicationDev :: IO (Int, Application)
getApplicationDev =
- defaultDevelApp loader getApplication
+ defaultDevelApp loader makeApplication
where
loader = loadConfig (configSettings Development)
View
@@ -16,30 +16,21 @@ module Foundation
import Prelude
import Yesod hiding (setTitle)
import Yesod.Static
-import Settings.StaticFiles
import Yesod.Auth
import Yesod.Auth.OpenId
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Logger (Logger, logMsg, formatLogText)
import Network.HTTP.Conduit (Manager)
-#ifdef DEVELOPMENT
-import Yesod.Logger (logLazyText)
-#endif
import qualified Settings
-import qualified Data.ByteString.Lazy as L
import qualified Database.Persist.Store
+import Settings.StaticFiles
import Database.Persist.GenericSql
import Settings (widgetFile, setTitle, addKeywords, pandocFile)
import Model
import Text.Jasmine (minifym)
import Web.ClientSession (getKey)
import Text.Hamlet (hamletFile)
-#if DEVELOPMENT
-import qualified Data.Text.Lazy.Encoding
-#else
-import Network.Mail.Mime (sendmail)
-#endif
import Data.Text (Text)
import Data.Maybe (fromMaybe)
@@ -95,8 +86,11 @@ type Form x = Html -> MForm DevSite DevSite (FormResult x, Widget)
instance Yesod DevSite where
approot = ApprootMaster $ appRoot . settings
- -- Place the session key file in the config folder
- encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
+ -- 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
@@ -146,8 +140,8 @@ instance Yesod DevSite where
-- users receiving stale content.
addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
- -- Enable Javascript async loading
- yepnopeJs _ = Just $ Right $ StaticR js_modernizr_js
+ -- Place Javascript at bottom of the body tag so the rest of the page loads first
+ jsLoader _ = BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
-- Authorization
isAuthorized ManagePostsR _ = authorizeAdmin
@@ -230,14 +224,11 @@ instance YesodAuth DevSite where
where
-- updates username/email with values returned by openid
-- unless values exist there already
- updateFromAx :: PersistStore SqlPersist m
- => [(Text,Text)] -- ^ the @credsExtra@ returned from open id
- -> UserId -- ^ the user id to update
- -> SqlPersist m ()
+ updateFromAx :: PersistQuery SqlPersist m => [(Text, Text)] -> UserId -> SqlPersist m ()
updateFromAx keys uid = maybe (return ()) go =<< get uid
where
- go :: PersistStore SqlPersist m => User -> SqlPersist m ()
+ go :: PersistQuery SqlPersist m => User -> SqlPersist m ()
go u = do
case (userName u, lookup "openid.ext1.value.email" keys) of
(Nothing, val@(Just _)) -> update uid [UserName =. (parseNick val)]
@@ -269,14 +260,6 @@ instance YesodAuth DevSite where
setTitle "Login"
$(widgetFile "login")
--- Sends off your mail. Requires sendmail in production!
-deliver :: DevSite -> L.ByteString -> IO ()
-#ifdef DEVELOPMENT
-deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8
-#else
-deliver _ = sendmail
-#endif
-
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage DevSite FormMessage where
View
@@ -4,6 +4,7 @@ module Handler.Feed
) where
import Import
+import Prelude (head)
import Helpers.Post
import Yesod.RssFeed
import Text.Blaze (preEscapedText)
View
@@ -11,6 +11,7 @@ module Handler.Posts
) where
import Import
+import Prelude (init, last)
import Helpers.Post
import Yesod.Comments (addCommentsAuth)
import Yesod.Links
View
@@ -22,7 +22,7 @@ getTagR tag = do
return (records',widget')
defaultLayout $ do
- rssLink (FeedTagR tag) ("rss feed for tag " ++ T.unpack tag)
+ rssLink (FeedTagR tag) ("rss feed for tag " `T.append` tag)
setTitle $ "Tag: " `T.append` tag
addKeywords [tag]
$(widgetFile "tag")
View
@@ -1,6 +1,7 @@
module Handler.Users (getUsersR) where
import Import
+import Prelude (head)
import Control.Monad (forM)
import Data.Maybe (fromMaybe)
View
@@ -23,6 +23,7 @@ module Helpers.Post
) where
import Import
+import Prelude (init, last)
import Yesod.Markdown
import Yesod.Links
import Data.Time (UTCTime(..), getCurrentTime)
View
@@ -2,19 +2,25 @@ module Import
( module Prelude
, module Yesod
, module Foundation
- , (<>)
- , Text
+ , module Settings.StaticFiles
, module Data.Monoid
, module Control.Applicative
+ , Text
+#if __GLASGOW_HASKELL__ < 704
+ , (<>)
+#endif
) where
-import Prelude hiding (writeFile, readFile)
+import Prelude hiding (writeFile, readFile, head, tail, init, last)
import Yesod hiding (Route(..), setTitle)
import Foundation
import Data.Monoid (Monoid (mappend, mempty, mconcat))
import Control.Applicative ((<$>), (<*>), pure)
import Data.Text (Text)
+import Settings.StaticFiles
+#if __GLASGOW_HASKELL__ < 704
infixr 5 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
+#endif
View
@@ -48,7 +48,7 @@ staticDir = "static"
-- have to make a corresponding change here.
--
-- To see how this value is used, see urlRenderOverride in Foundation.hs
-staticRoot :: AppConfig DefaultEnv x -> Text
+staticRoot :: AppConfig DefaultEnv x -> Text
staticRoot conf = [st|#{appRoot conf}/static|]
@@ -66,7 +66,7 @@ setTitle :: Yesod m => Text -> GWidget s m ()
setTitle = Y.setTitle . toHtml . T.append "pbrisbin - "
addKeywords :: [Text] -> GWidget s m ()
-addKeywords ws = addHamletHead [hamlet|<meta name="keywords" content="#{format ws}">|]
+addKeywords ws = toWidgetHead [hamlet|<meta name="keywords" content="#{format ws}">|]
where
-- add some default keywords, and make the comma separated list
View
@@ -4,7 +4,6 @@ build() {
cabal clean
cabal configure
cabal build
- cabal check
}
deploy() {
View
@@ -46,23 +46,24 @@ library
Helpers.Profile
Helpers.Search
- ghc-options: -Wall -O0
+ ghc-options: -Wall -threaded -O0
cpp-options: -DDEVELOPMENT
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
- OverloadedStrings
MultiParamTypeClasses
TypeFamilies
GADTs
GeneralizedNewtypeDeriving
FlexibleContexts
+ EmptyDataDecls
+ NoMonomorphismRestriction
FlexibleInstances
TypeSynonymInstances
- EmptyDataDecls
+ OverloadedStrings
executable devsite
if flag(library-only)
@@ -87,36 +88,38 @@ executable devsite
GADTs
GeneralizedNewtypeDeriving
FlexibleContexts
+ EmptyDataDecls
+ NoMonomorphismRestriction
FlexibleInstances
TypeSynonymInstances
- EmptyDataDecls
+ OverloadedStrings
build-depends: base >= 4 && < 5
- , yesod >= 0.10 && < 0.11
- , yesod-core >= 0.10 && < 0.11
- , yesod-auth >= 0.8 && < 0.9
- , yesod-static >= 0.10 && < 0.11
- , yesod-default >= 0.6 && < 0.7
- , yesod-form >= 0.4 && < 0.5
- , mime-mail >= 0.3.0.3 && < 0.5
+ , yesod >= 1.0 && < 1.1
+ , yesod-core >= 1.0 && < 1.1
+ , yesod-auth >= 1.0 && < 1.1
+ , yesod-static >= 1.0 && < 1.1
+ , yesod-default >= 1.0 && < 1.1
+ , yesod-form >= 1.0 && < 1.1
, clientsession >= 0.7.3 && < 0.8
, bytestring >= 0.9 && < 0.10
, text >= 0.11 && < 0.12
- , persistent >= 0.8 && < 0.9
- , persistent-postgresql >= 0.8 && < 0.9
+ , persistent >= 0.9 && < 0.10
+ , persistent-postgresql >= 0.9 && < 0.10
, template-haskell
- , hamlet >= 0.10 && < 0.11
- , shakespeare-css >= 0.10 && < 0.11
- , shakespeare-js >= 0.11 && < 0.12
- , shakespeare-text >= 0.10 && < 0.11
+ , hamlet >= 1.0 && < 1.1
+ , shakespeare-css >= 1.0 && < 1.1
+ , shakespeare-js >= 1.0 && < 1.1
+ , shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.0.14 && < 0.1
, monad-control >= 0.3 && < 0.4
- , wai-extra >= 1.1 && < 1.2
- , yaml >= 0.5 && < 0.6
- , http-conduit >= 1.2 && < 1.3
+ , wai-extra >= 1.2 && < 1.3
+ , yaml >= 0.7 && < 0.8
+ , http-conduit >= 1.4 && < 1.5
+ , directory >= 1.1 && < 1.2
+ , warp >= 1.2 && < 1.3
, blaze-html
- , directory
, filepath
, friendly-time
, gravatar
View
@@ -1,10 +1,10 @@
import Prelude
import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain)
-import Application (getApplication)
+import Application (makeApplication)
main :: IO ()
-main = defaultMain (fromArgs parseNothing) getApplication
+main = defaultMain (fromArgs parseNothing) makeApplication
-- I don't need the stupid Extra
parseNothing :: Monad m => a -> b -> m ()

0 comments on commit 58a27ec

Please sign in to comment.