We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

Commit fc9fe59c authored by David L. L. Thomas's avatar David L. L. Thomas

Yesod 1.2 migration

parent 817166b5
......@@ -11,13 +11,14 @@ import Yesod.Default.Config
import Yesod.Default.Main
import Yesod.Default.Handlers
import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
import qualified Database.Persist.Store
import Database.Persist.GenericSql (printMigration, runMigration)
import qualified Database.Persist
import Network.HTTP.Conduit (newManager, def)
import Version
import Control.Monad.Logger (runLoggingT)
import Control.Monad.Trans.Resource
import System.IO (stdout)
import System.Log.FastLogger (mkLogger)
import Control.Monad.Logger
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
......@@ -74,22 +75,29 @@ makeFoundation conf = 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)
runStderrLoggingT $ Database.Persist.Store.runPool dbconf (printMigration migrateAll >> runMigration migrateAll) p
Database.Persist.loadConfig >>=
Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
logger <- mkLogger True stdout
let foundation = App conf s p manager dbconf logger
runLoggingT
(Database.Persist.runPool dbconf (printMigration migrateAll >> runMigration migrateAll) p)
(messageLoggerSource foundation logger)
now <- getCurrentTime
let (base, diff) = version
runStderrLoggingT $ runResourceT $ Database.Persist.Store.runPool dbconf (insert_ $ Build now base diff) p
runLoggingT
(runResourceT $ Database.Persist.runPool dbconf (insert_ $ Build now base diff) p)
(messageLoggerSource foundation logger)
return $ App conf s p manager dbconf
return foundation
-- for yesod devel
getApplicationDev :: IO (Int, Application)
getApplicationDev =
defaultDevelApp loader makeApplication
where
loader = loadConfig (configSettings Development)
loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}
......@@ -10,7 +10,7 @@ import qualified Text.Blaze.Html5.Attributes as Attr
import qualified Text.Blaze.Html5 as Html
import Data.Either
import Data.Function (on)
import qualified Data.Function as FUN
import Data.List as L
import Data.String
......@@ -26,15 +26,15 @@ isRight _ = False
unlinesHtml :: [Html] -> Html
unlinesHtml = sequence_ . L.intersperse Html.br
prettyHtml :: HasGithubRepo (GHandler sub master) => [Parser Pretty] -> Text -> GHandler sub master Html
prettyHtml :: (Monad m, HasGithubRepo (HandlerT site m)) => [Parser Pretty] -> Text -> HandlerT site m Html
prettyHtml filters text = do
case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of
Right result -> do
let pieces = L.concatMap (\(a, b) -> L.map Left a ++ if T.length b > 0 then [Right b] else []) $ fmap (fmap T.concat) $ fmap partitionEithers $ L.groupBy ((==) `on` isRight) result
let pieces = L.concatMap (\(a, b) -> L.map Left a ++ if T.length b > 0 then [Right b] else []) $ fmap (fmap T.concat) $ fmap partitionEithers $ L.groupBy ((==) `FUN.on` isRight) result
fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
Left err -> error err
renderPretty :: HasGithubRepo (GHandler sub master) => Pretty -> GHandler sub master Html
renderPretty :: (Monad m, HasGithubRepo (HandlerT site m)) => Pretty -> HandlerT site m Html
renderPretty pretty = case pretty of
RawHtml html -> return html
GithubTicket int -> do
......
{-# LANGUAGE FlexibleInstances #-}
module Foundation where
import Prelude
......@@ -12,19 +13,20 @@ import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist.Store
import qualified Database.Persist
import Database.Persist.Sql (SqlPersistT)
import Settings.StaticFiles
import Database.Persist.GenericSql
import Settings (widgetFile, Extra (..))
import Model
import Text.Jasmine (minifym)
import Web.ClientSession (getKey)
import Text.Hamlet (hamletFile)
import System.Log.FastLogger (Logger)
import Model.Currency
import Model.Role.Internal
import Control.Applicative
import Control.Monad.Trans.Resource
import Data.Int (Int64)
import Data.Text (Text)
......@@ -50,9 +52,10 @@ import Data.Time
data App = App
{ settings :: AppConfig DefaultEnv Extra
, getStatic :: Static -- ^ Settings for static file serving.
, connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
, connPool :: Database.Persist.PersistConfigPool Settings.PersistConf -- ^ Database connection pool.
, httpManager :: Manager
, persistConfig :: Settings.PersistConfig
, persistConfig :: Settings.PersistConf
, appLogger :: Logger
}
......@@ -84,7 +87,7 @@ mkMessage "App" "messages" "en"
-- 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)
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
licenseText :: LB.ByteString
licenseText = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius|
......@@ -118,10 +121,9 @@ instance Yesod App where
-- 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"
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher (48 * 60 * 60)
return . Just $ clientSessionBackend2 key getCachedDate
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
(48 * 60 * 60)
"config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
......@@ -138,7 +140,7 @@ instance Yesod App where
addStylesheet $ StaticR css_bootstrap_min_css
addScript $ StaticR js_bootstrap_min_js
$(widgetFile "default-layout")
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
giveUrlRenderer $(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
......@@ -153,27 +155,29 @@ instance Yesod App where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
errorHandler (PermissionDenied _) = fmap chooseRep $ defaultLayout $ do
setTitle "Permission Denied"
maybe_user <- lift maybeAuth
toWidget [hamlet|$newline never
<h1>Permission Denied
<p>
$maybe _ <- maybe_user
You do not have permission to view this page at this time. #
If you think you should, #
<a href="@{ContactR}">let us know #
and we'll fix it for you or everyone. #
Otherwise, you can always go to our #
<a href="@{HomeR}">main page
.
$nothing
You are not logged in, and this page is not publically visible. #
<a href="@{AuthR LoginR}">Log in or create an account #
or return to our #
<a href="@{HomeR}">main page
.
|]
errorHandler (PermissionDenied _) = do
maybe_user <- maybeAuth
selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Permission Denied"
toWidget [hamlet|$newline never
<h1>Permission Denied
<p>
$maybe _ <- maybe_user
You do not have permission to view this page at this time. #
If you think you should, #
<a href="@{ContactR}">let us know #
and we'll fix it for you or everyone. #
Otherwise, you can always go to our #
<a href="@{HomeR}">main page
.
$nothing
You are not logged in, and this page is not publically visible. #
<a href="@{AuthR LoginR}">Log in or create an account #
or return to our #
<a href="@{HomeR}">main page
.
|]
errorHandler other_error = defaultErrorHandler other_error
......@@ -251,7 +255,7 @@ instance Yesod App where
role <- maybe Uninvited (userRole . entityVal) <$> maybeAuth
return $ roleCanView role write route
require :: (WikiPage -> Role) -> Text -> GHandler sub App AuthResult
require :: (WikiPage -> Role) -> Text -> HandlerT App IO AuthResult
require permission target = do
role <- maybe Uninvited (userRole . entityVal) <$> maybeAuth
maybe_page <- runDB $ getBy $ UniqueWikiTarget target
......@@ -279,19 +283,15 @@ roleCanView Public _ _ = error "No user should actually have the role 'Public'"
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlPersist
runDB f = do
master <- getYesod
Database.Persist.Store.runPool
(persistConfig master)
f
(connPool master)
type YesodPersistBackend App = SqlPersistT
runDB = defaultRunDB persistConfig connPool
instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner connPool
authBrowserIdFixed :: AuthPlugin App
authBrowserIdFixed =
let complete = PluginR "browserid" []
login :: (Route Auth -> Route App) -> GWidget sub App ()
login :: (Route Auth -> Route App) -> WidgetT App IO ()
login toMaster = do
addScriptRemote browserIdJs
......@@ -327,7 +327,7 @@ authBrowserIdFixed =
<img src="https://browserid.org/i/persona_sign_in_blue.png">
|]
in authBrowserId { apLogin = login }
in (authBrowserId def) { apLogin = login }
instance YesodAuth App where
......@@ -353,10 +353,10 @@ instance YesodAuth App where
authHttpManager = httpManager
loginHandler = do
app <- getYesod
rtm <- getRouteToMaster
app <- lift getYesod
toParent <- getRouteToParent
defaultLayout $(widgetFile "auth")
lift $ defaultLayout $(widgetFile "auth")
......@@ -365,7 +365,7 @@ instance YesodJquery App
class HasGithubRepo a where
getGithubRepo :: a (Maybe Text)
instance HasGithubRepo (GHandler App App) where
instance (MonadBaseControl IO m, MonadUnsafeIO m, MonadIO m, MonadThrow m) => HasGithubRepo (HandlerT App m) where
getGithubRepo = extraGithubRepo . appExtra . settings <$> getYesod
-- This instance is required to use forms. You can modify renderMessage to
......
......@@ -6,7 +6,7 @@ import Model.User
import Widgets.Sidebar
getApplicationR :: CommitteeApplicationId -> Handler RepHtml
getApplicationR :: CommitteeApplicationId -> Handler Html
getApplicationR application_id = do
(application, user) <- runDB $ do
application <- get404 application_id
......
......@@ -6,7 +6,7 @@ import Model.Role
import Widgets.Sidebar
getApplicationsR :: Handler RepHtml
getApplicationsR :: Handler Html
getApplicationsR = do
Entity viewer_id viewer <- requireAuth
now <- liftIO getCurrentTime
......@@ -16,7 +16,9 @@ getApplicationsR = do
then runDB $ selectList [] [ Desc CommitteeApplicationCreatedTs ]
else return []
_ <- runDB $ update viewer_id [ UserReadApplications =. now ]
_ <- runDB $ update $ \ user -> do
set user [ UserReadApplications =. val now ]
where_ (user ^. UserId ==. val viewer_id)
defaultLayout $(widgetFile "applications")
......@@ -8,7 +8,7 @@ import qualified Data.Text as T
import Text.Blaze.Html5 (br)
getBuildFeedR :: Handler RepAtomRss
getBuildFeedR :: Handler TypedContent
getBuildFeedR = do
builds :: [Build] <- fmap (map entityVal) $ runDB $ selectList [] [Desc BuildBootTime]
......@@ -16,7 +16,7 @@ getBuildFeedR = do
feed_url = BuildFeedR
home_url = HomeR
author = "Snowdrift Team"
desc = "Deployments of the Snowdrift site"
description = "Deployments of the Snowdrift site"
lang = "en"
time :: UTCTime
(time:_) = map buildBootTime builds
......@@ -33,4 +33,4 @@ getBuildFeedR = do
return entry
newsFeed $ Feed title feed_url home_url author desc lang time entries
newsFeed $ Feed title feed_url home_url author description lang time entries
......@@ -17,7 +17,7 @@ committeeForm now (Entity user_id user) = renderBootstrap $
<*> areq textareaField "Personal statement (why you want to join the committee):" Nothing
<*> aopt textareaField "Any other comments:" Nothing
getCommitteeR :: Handler RepHtml
getCommitteeR :: Handler Html
getCommitteeR = do
user <- requireAuth
now <- liftIO getCurrentTime
......@@ -25,7 +25,7 @@ getCommitteeR = do
defaultLayout $(widgetFile "committee")
postCommitteeR :: Handler RepHtml
postCommitteeR :: Handler Html
postCommitteeR = do
user <- requireAuth
now <- liftIO getCurrentTime
......
......@@ -8,13 +8,13 @@ import Widgets.Sidebar
contactForm :: Form Textarea
contactForm = renderDivs $ areq textareaField "" Nothing
getContactR :: Handler RepHtml
getContactR :: Handler Html
getContactR = do
(contact_form, _) <- generateFormPost contactForm
defaultLayout $(widgetFile "contact")
postContactR :: Handler RepHtml
postContactR :: Handler Html
postContactR = do
maybe_user_id <- maybeAuthId
now <- liftIO getCurrentTime
......
......@@ -4,7 +4,7 @@ import Import
-- import Widgets.Sidebar
getFaqR :: Handler RepHtml
getFaqR :: Handler Html
getFaqR = do
setMessage "We don't have a list of frequently asked questions yet - hopefully the about page will answer yours."
redirect $ WikiR "about"
......
......@@ -5,6 +5,6 @@ import Import
import Widgets.Sidebar
getHomeR :: Handler RepHtml
getHomeR :: Handler Html
getHomeR = defaultLayout $(widgetFile "homepage")
......@@ -7,12 +7,12 @@ import Model.Role
import Widgets.Sidebar
getInvitationR :: Text -> Handler RepHtml
getInvitationR :: Text -> Handler Html
getInvitationR code = do
Entity invite_id invite <- runDB $ getBy404 $ UniqueInvite code
maybe_user_id <- maybeAuthId
when (isNothing maybe_user_id)
when (maybe_user_id == Nothing)
setUltDestCurrent
alreadyExpired
......@@ -22,9 +22,9 @@ getInvitationR code = do
defaultLayout $ $(widgetFile "invitation")
postInvitationR :: Text -> Handler RepHtml
postInvitationR :: Text -> Handler Html
postInvitationR code = do
viewer_id <- requireAuthId
viewer_id :: UserId <- requireAuthId
now <- liftIO getCurrentTime
role <- runDB $ do
Entity invite_id invite <- getBy404 $ UniqueInvite code
......@@ -32,11 +32,17 @@ postInvitationR code = do
if inviteRedeemed invite
then return Nothing
else do
update invite_id [ InviteRedeemed =. True
, InviteRedeemedTs =. Just now
, InviteRedeemedBy =. Just viewer_id
]
update viewer_id [ UserRole =. inviteRole invite ]
update $ \ i -> do
set i [ InviteRedeemed =. val True
, InviteRedeemedTs =. val (Just now)
, InviteRedeemedBy =. val (Just viewer_id)
]
where_ ( i ^. InviteId ==. val invite_id )
update $ \ user -> do
where_ (user ^. UserId ==. val viewer_id)
set user [ UserRole =. val (inviteRole invite) ]
return $ Just $ inviteRole invite
redirect $ maybe (InvitationR code) roleDefaultTarget role
......
......@@ -21,7 +21,7 @@ inviteForm role = renderBootstrap $ (,)
<$> areq textField "About this invitation:" Nothing
<*> areq (roleField role) "Type of Invite:" (Just GeneralPublic)
getInviteR :: Handler RepHtml
getInviteR :: Handler Html
getInviteR = do
Entity viewer_id viewer <- requireAuth
now <- liftIO getCurrentTime
......@@ -38,11 +38,22 @@ getInviteR = do
Admin -> True
_ -> False
outstanding_invite_filter = (if can_view_all then [] else [ InviteUser ==. viewer_id ]) ++ [ InviteRedeemed ==. False ]
redeemed_invite_filter = (if can_view_all then [] else [ InviteUser ==. viewer_id ]) ++ [ InviteRedeemed ==. True ]
restrict_view =
if can_view_all
then const id
else (\ invite -> ((invite ^. InviteUser ==. val viewer_id) ||.))
outstanding_invites <- runDB $ select $ from $ \ invite -> do
where_ ( restrict_view invite $ invite ^. InviteRedeemed ==. val False )
orderBy [ desc (invite ^. InviteCreatedTs) ]
return invite
redeemed_invites <- runDB $ select $ from $ \ invite -> do
where_ ( restrict_view invite $ invite ^. InviteRedeemed ==. val True )
orderBy [ desc (invite ^. InviteCreatedTs) ]
limit 20
return invite
outstanding_invites <- runDB $ selectList outstanding_invite_filter [ Desc InviteCreatedTs ]
redeemed_invites <- runDB $ selectList redeemed_invite_filter [ Desc InviteRedeemedTs, LimitTo 20 ]
let redeemed_users = S.fromList $ mapMaybe (inviteRedeemedBy . entityVal) redeemed_invites
redeemed_inviters = S.fromList $ map (inviteUser . entityVal) redeemed_invites
outstanding_inviters = S.fromList $ map (inviteUser . entityVal) outstanding_invites
......@@ -63,7 +74,7 @@ getInviteR = do
defaultLayout $(widgetFile "invite")
postInviteR :: Handler RepHtml
postInviteR :: Handler Html
postInviteR = do
Entity user_id user <- requireAuth
now <- liftIO getCurrentTime
......
......@@ -15,7 +15,7 @@ data Lib =
, libOrigRoute :: Text
}
getJsLicenseR :: Handler RepHtml
getJsLicenseR :: Handler Html
getJsLicenseR = do
app <- getYesod
render <- getUrlRender
......
......@@ -4,5 +4,5 @@ import Import
import Widgets.Sidebar
getMarkdownTutorialR :: Handler RepHtml
getMarkdownTutorialR :: Handler Html
getMarkdownTutorialR = defaultLayout $(widgetFile "markdown")
......@@ -10,26 +10,32 @@ import qualified Data.Map as M
import Widgets.Sidebar
getMessagesR :: Handler RepHtml
getMessagesR :: Handler Html
getMessagesR = do
Entity viewer_id viewer <- requireAuth
now <- liftIO getCurrentTime
messages <-
runDB $ if userRole viewer == CommitteeMember || userRole viewer == Admin
then selectList
( [ MessageTo ==. Just viewer_id ]
||. [ MessageTo ==. Nothing ]
) [ Desc MessageCreatedTs ]
else selectList [ MessageTo ==. Just viewer_id ] [ Desc MessageCreatedTs ]
users <- runDB $ selectList [ UserId <-. mapMaybe (messageFrom . entityVal) messages ] []
runDB $ let view_all = if userRole viewer == CommitteeMember || userRole viewer == Admin
then (\ message -> (||. message ^. MessageTo ==. val Nothing))
else const id
in select $ from $ \ message -> do
where_ $ view_all message ( message ^. MessageTo ==. val (Just viewer_id) )
orderBy [ desc (message ^. MessageCreatedTs) ]
return message
users <- runDB $ select $ from $ \ user -> do
where_ (user ^. UserId `in_` valList (mapMaybe (messageFrom . entityVal) messages))
return user
let user_map = M.fromList $ map (entityKey &&& entityVal) users
getUserName user_id =
let user = user_map M.! user_id
in fromMaybe (userIdent user) (userName user)
_ <- runDB $ update viewer_id [ UserReadMessages =. now ]
_ <- runDB $ update $ \ user -> do
set user [ UserReadMessages =. val now ]
where_ ( user ^. UserId ==. val viewer_id )
defaultLayout $(widgetFile "messages")
......@@ -2,7 +2,7 @@ module Handler.PostLogin where
import Import
getPostLoginR :: Handler RepHtml
getPostLoginR :: Handler Html
getPostLoginR = do
app <- getYesod
redirectUltDest $ loginDest app
......@@ -2,5 +2,5 @@ module Handler.Privacy where
import Import
getPrivacyR :: Handler RepHtml
getPrivacyR :: Handler Html
getPrivacyR = defaultLayout $(widgetFile "priv")
......@@ -18,7 +18,7 @@ import Widgets.Sidebar
import Widgets.Markdown
import Database.Esqueleto
import Database.Persist.GenericSql.Raw
-- import Database.Persist.Sql.Raw
import Yesod.Markdown
......@@ -28,7 +28,7 @@ lookupGetParamDefault name def = do
return $ fromMaybe def $ maybe_value >>= readMaybe . T.unpack
getProjectsR :: Handler RepHtml
getProjectsR :: Handler Html
getProjectsR = do
page <- lookupGetParamDefault "page" 0
per_page <- lookupGetParamDefault "count" 20
......@@ -47,7 +47,7 @@ getProjectsR = do
defaultLayout $(widgetFile "projects")
getProjectR :: Text -> Handler RepHtml
getProjectR :: Text -> Handler Html
getProjectR project_handle = do
maybe_viewer_id <- maybeAuthId
......@@ -64,10 +64,10 @@ getProjectR project_handle = do
renderProject :: Maybe Text
-> ProjectGeneric SqlBackend
-> Project
-> [Int64]
-> Maybe (Entity (PledgeGeneric SqlBackend))
-> GWidget App App ()
-> Maybe (Entity Pledge)
-> WidgetT App IO ()
renderProject maybe_project_handle project pledges pledge = do
let share_value = projectShareValue project
users = fromIntegral $ length pledges
......@@ -77,7 +77,7 @@ renderProject maybe_project_handle project pledges pledge = do
maybe_shares = pledgeShares . entityVal <$> pledge
((_, update_shares), _) <- lift $ generateFormGet $ buySharesForm $ fromMaybe 0 maybe_shares
((_, update_shares), _) <- handlerToWidget $ generateFormGet $ buySharesForm $ fromMaybe 0 maybe_shares
$(widgetFile "project")
......@@ -112,7 +112,7 @@ previewProjectForm project =
<*> (map T.strip . T.splitOn "," <$> areq hiddenField "" (T.intercalate ", " . snd <$> project))
getEditProjectR :: Text -> Handler RepHtml
getEditProjectR :: Text -> Handler Html
getEditProjectR project_handle = do
Entity project_id project <- runDB $ getBy404 $ UniqueProjectHandle project_handle
......@@ -128,7 +128,7 @@ getEditProjectR project_handle = do
defaultLayout $(widgetFile "edit_project")
postProjectR :: Text -> Handler RepHtml
postProjectR :: Text -> Handler Html
postProjectR project_handle = do
viewer <- requireAuth
......@@ -204,7 +204,7 @@ postProjectR project_handle = do
redirect $ ProjectR project_handle
getProjectPatronsR :: Text -> Handler RepHtml
getProjectPatronsR :: Text -> Handler Html
getProjectPatronsR project_handle = do
page <- lookupGetParamDefault "page" 0
per_page <- lookupGetParamDefault "count" 20
......
......@@ -18,16 +18,16 @@ import Data.Text.PrettyHtml
import Prelude (head)
import Data.Time (addUTCTime)
import Data.Time (addUTCTime)
import Data.List (sortBy)
import Data.Tree (unfoldTreeM_BF, levels)
import Data.Function (on)
import qualified Data.Function as FUN
getRepoFeedR :: HasGithubRepo Handler => Handler RepAtomRss
getRepoFeedR :: HasGithubRepo Handler => Handler TypedContent
getRepoFeedR = do