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

Application.hs 12 KB
Newer Older
David L. L. Thomas's avatar
David L. L. Thomas committed
1
{-# OPTIONS_GHC -fno-warn-orphans #-}
David L. L. Thomas's avatar
David L. L. Thomas committed
2 3
{-# LANGUAGE TupleSections #-}

David L. L. Thomas's avatar
David L. L. Thomas committed
4 5 6 7 8 9 10
module Application
    ( makeApplication
    , getApplicationDev
    , makeFoundation
    ) where

import Import
11
import SnowdriftEventHandler
12 13
import Version

Mitchell Rosen's avatar
Mitchell Rosen committed
14
import           Control.Concurrent                   (forkIO, threadDelay)
Mitchell Rosen's avatar
Mitchell Rosen committed
15
import           Control.Concurrent.STM               (atomically, newTChanIO, tryReadTChan)
Mitchell Rosen's avatar
Mitchell Rosen committed
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
import           Control.Monad.Logger                 (runLoggingT, runStderrLoggingT)
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Data.ByteString                      (ByteString)
import           Data.Default                         (def)
import qualified Data.List                            as L
import           Data.Text                            as T
import qualified Data.Text.IO                         as T
import qualified Database.Persist
import           Database.Persist.Postgresql          (pgConnStr, withPostgresqlConn)
import           Network.HTTP.Client.Conduit          (newManager)
import           Network.Wai.Middleware.RequestLogger ( mkRequestLogger, outputFormat, OutputFormat (..)
                                                      , IPAddrSource (..), destination
                                                      )
import           Network.Wai.Logger                   (clockDateCacher)
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import           System.Directory
import           System.Environment                   (lookupEnv)
import           System.Log.FastLogger                (newStdoutLoggerSet, defaultBufSize, flushLogStr)
Bryan Richter's avatar
Bryan Richter committed
35
import           System.IO                            (stderr)
Mitchell Rosen's avatar
Mitchell Rosen committed
36 37 38 39
import           System.Posix.Env.ByteString
import           Yesod.Core.Types                     (loggerSet, Logger (Logger))
import           Yesod.Default.Config
import           Yesod.Default.Handlers
40
import           Yesod.Default.Main hiding (LogFunc)
Mitchell Rosen's avatar
Mitchell Rosen committed
41

David L. L. Thomas's avatar
David L. L. Thomas committed
42 43
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
44 45

import Handler.BuildFeed
46
import Handler.Comment
David L. L. Thomas's avatar
David L. L. Thomas committed
47
import Handler.Home
wolftune's avatar
wolftune committed
48
import Handler.Donate
49
import Handler.HonorPledge
David L. L. Thomas's avatar
David L. L. Thomas committed
50
import Handler.Image
David L. L. Thomas's avatar
David L. L. Thomas committed
51 52 53
import Handler.Invitation
import Handler.JsLicense
import Handler.MarkdownTutorial
54
import Handler.Notification
55 56 57
import Handler.PostLogin
import Handler.Privacy
import Handler.Project
58
import Handler.Project.Signup
David L. L. Thomas's avatar
David L. L. Thomas committed
59
import Handler.ProjectBlog
60
import Handler.RepoFeed
61
import Handler.ResetPassword
David L. L. Thomas's avatar
David L. L. Thomas committed
62
import Handler.SnowdriftEvent
63
import Handler.ToU
64
import Handler.Trademarks
65
import Handler.User
66
import Handler.User.Comment
67 68 69
import Handler.Volunteer
import Handler.Who
import Handler.Widget
David L. L. Thomas's avatar
David L. L. Thomas committed
70
import Handler.Wiki
71
import Handler.Wiki.Comment
72

Mitchell Rosen's avatar
Mitchell Rosen committed
73
import Widgets.Navbar
74

75
runSql :: MonadIO m => Text -> ReaderT SqlBackend m ()
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
76 77
runSql = flip rawExecute [] -- TODO quasiquoter?

78 79
version :: (Text, Text)
version = $(mkVersion)
David L. L. Thomas's avatar
David L. L. Thomas committed
80 81 82 83 84 85

-- This line actually creates our YesodDispatch 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

David L. L. Thomas's avatar
David L. L. Thomas committed
86 87 88 89 90 91 92 93 94 95 96
-- probably not thread safe
withEnv :: (MonadIO m) => ByteString -> ByteString -> m a -> m a
withEnv k v action = do
    original <- liftIO $ getEnv k

    liftIO $ setEnv k v True
    result <- action
    liftIO $ maybe (unsetEnv k) (\ v' -> setEnv k v' True) original

    return result

David L. L. Thomas's avatar
David L. L. Thomas committed
97 98 99 100
-- 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.
101
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
David L. L. Thomas's avatar
David L. L. Thomas committed
102 103
makeApplication conf = do
    foundation <- makeFoundation conf
104 105 106 107 108 109 110 111 112 113 114

    -- Initialize the logging middleware
    logWare <- mkRequestLogger def
        { outputFormat =
            if development
                then Detailed True
                else Apache FromSocket
        , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation
        }

    -- Create the WAI application and apply middlewares
David L. L. Thomas's avatar
David L. L. Thomas committed
115
    app <- toWaiAppPlain foundation
116 117
    let logFunc = messageLoggerSource foundation (appLogger foundation)
    return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
David L. L. Thomas's avatar
David L. L. Thomas committed
118

119 120
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
David L. L. Thomas's avatar
David L. L. Thomas committed
121 122
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
123
    manager <- newManager
David L. L. Thomas's avatar
David L. L. Thomas committed
124 125
    s <- staticSite
    dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
David L. L. Thomas's avatar
David L. L. Thomas committed
126 127
              Database.Persist.loadConfig >>=
              Database.Persist.applyEnv
Bryan Richter's avatar
Bryan Richter committed
128
    pool <- Database.Persist.createPoolConfig dbconf
David L. L. Thomas's avatar
David L. L. Thomas committed
129

130 131 132 133 134 135 136
    loggerSet' <- newStdoutLoggerSet defaultBufSize
    (getter, updater) <- clockDateCacher

    -- If the Yesod logger (as opposed to the request logger middleware) is
    -- used less than once a second on average, you may prefer to omit this
    -- thread and use "(updater >> getter)" in place of "getter" below.  That
    -- would update the cache every time it is used, instead of every second.
Mitchell Rosen's avatar
Mitchell Rosen committed
137
    let updateLoop = forever $ do
138 139 140 141
            threadDelay 1000000
            updater
            flushLogStr loggerSet'
            updateLoop
Mitchell Rosen's avatar
Mitchell Rosen committed
142
    void $ forkIO updateLoop
143

Mitchell Rosen's avatar
Mitchell Rosen committed
144
    event_chan <- newTChanIO
145
    let logger = Yesod.Core.Types.Logger loggerSet' getter
Mitchell Rosen's avatar
Mitchell Rosen committed
146 147 148 149
        foundation = App
                       navbar
                       conf
                       s
Bryan Richter's avatar
Bryan Richter committed
150
                       pool
Mitchell Rosen's avatar
Mitchell Rosen committed
151 152 153 154
                       manager
                       dbconf
                       logger
                       event_chan
155
                       snowdriftEventHandlers
156 157

    -- Perform database migration using our application's logging settings.
David L. L. Thomas's avatar
David L. L. Thomas committed
158
    case appEnv conf of
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
159
        Testing -> withEnv "PGDATABASE" "template1" (applyEnv $ persistConfig foundation) >>= \ dbconf' -> do
160
                options <- maybe [] L.words <$> lookupEnv "SNOWDRIFT_TESTING_OPTIONS"
161 162

                unless (elem "nodrop" options) $ do
163
                    runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runReaderT $ do
164 165 166 167 168
                        liftIO $ putStrLn "dropping database..."
                        runSql "DROP DATABASE IF EXISTS snowdrift_test;"
                        liftIO $ putStrLn "creating database..."
                        runSql "CREATE DATABASE snowdrift_test WITH TEMPLATE snowdrift_test_template;"
                        liftIO $ putStrLn "ready."
David L. L. Thomas's avatar
David L. L. Thomas committed
169 170
        _ -> return ()

Bryan Richter's avatar
Bryan Richter committed
171 172 173
    let migration = runSqlPool
            (doManualMigration >> runMigration migrateAll >> migrateTriggers)
            pool
Mitchell Rosen's avatar
Mitchell Rosen committed
174

175
    void $ runLoggingT
Mitchell Rosen's avatar
Mitchell Rosen committed
176 177
        migration
        (messageLoggerSource foundation logger)
178 179 180

    now <- getCurrentTime
    let (base, diff) = version
David L. L. Thomas's avatar
David L. L. Thomas committed
181
    runLoggingT
Bryan Richter's avatar
Bryan Richter committed
182 183 184 185
        (Database.Persist.runPool
            dbconf
            (insert_ $ Build now base diff)
            pool)
David L. L. Thomas's avatar
David L. L. Thomas committed
186
        (messageLoggerSource foundation logger)
187

Mitchell Rosen's avatar
Mitchell Rosen committed
188 189
    forkEventHandler foundation

David L. L. Thomas's avatar
David L. L. Thomas committed
190
    return foundation
David L. L. Thomas's avatar
David L. L. Thomas committed
191 192 193 194

-- for yesod devel
getApplicationDev :: IO (Int, Application)
getApplicationDev =
195
    defaultDevelApp loader (fmap fst . makeApplication)
David L. L. Thomas's avatar
David L. L. Thomas committed
196
  where
David L. L. Thomas's avatar
David L. L. Thomas committed
197
    loader = Yesod.Default.Config.loadConfig (configSettings Development)
David L. L. Thomas's avatar
David L. L. Thomas committed
198 199
        { csParseExtra = parseExtra
        }
200

Bryan Richter's avatar
Bryan Richter committed
201 202 203 204 205 206 207 208 209 210
doManualMigration :: (MonadIO m, MonadLogger m, Functor m)
                  => SqlPersistT m ()
doManualMigration = do
    deprecatedApplyManualMigrations
    saveUnsafeMigrations

deprecatedApplyManualMigrations
    :: (MonadLogger m, MonadIO m)
    => ReaderT SqlBackend m ()
deprecatedApplyManualMigrations = do
David L. L. Thomas's avatar
Bugfix  
David L. L. Thomas committed
211
    $(logInfo) "creating version table"
David L. L. Thomas's avatar
David L. L. Thomas committed
212

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
213
    runSql "CREATE TABLE IF NOT EXISTS \"database_version\" (\"id\" SERIAL PRIMARY KEY UNIQUE, \"last_migration\" INT8 NOT NULL);"
David L. L. Thomas's avatar
David L. L. Thomas committed
214

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
215
    last_migration <- select $ from return
David L. L. Thomas's avatar
David L. L. Thomas committed
216 217

    migration_number <- case last_migration of
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
218
        [] -> insert (DatabaseVersion 0) >> return 0
David L. L. Thomas's avatar
David L. L. Thomas committed
219 220 221 222 223
        [Entity _ (DatabaseVersion migration)] -> return migration
        _ -> error "multiple entries in DB version table"

    unfiltered_migration_files <- liftIO $ getDirectoryContents "migrations"

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
224
    let migration_files :: [(Int, String)]
David L. L. Thomas's avatar
David L. L. Thomas committed
225 226 227 228 229
        migration_files = L.sort
            $ L.filter ((> migration_number) . fst)
            $ mapMaybe (\ s -> fmap (,s) $ readMaybe =<< L.stripPrefix "migrate" s)
            unfiltered_migration_files

David L. L. Thomas's avatar
Bugfix  
David L. L. Thomas committed
230 231 232
    forM_ (L.map (("migrations/" <>) . snd) migration_files) $ \ file -> do
        $(logWarn) $ "running " <> T.pack file <> "..."
        migration <- liftIO $ T.readFile file
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
233
        runSql migration
David L. L. Thomas's avatar
David L. L. Thomas committed
234

David L. L. Thomas's avatar
Bugfix  
David L. L. Thomas committed
235
    let new_last_migration = L.maximum $ migration_number : L.map fst migration_files
David L. L. Thomas's avatar
David L. L. Thomas committed
236

David L. L. Thomas's avatar
David L. L. Thomas committed
237 238
    update $ flip set [ DatabaseVersionLastMigration =. val new_last_migration ]

Bryan Richter's avatar
Bryan Richter committed
239
    -- This is where new safe migrations used to be recorded.
David L. L. Thomas's avatar
David L. L. Thomas committed
240

Bryan Richter's avatar
Bryan Richter committed
241 242 243 244 245 246 247
-- | Automatically save unsafe migrations, if they exist.
--
-- We'll still blow up with runMigration, but we'll be one step closer to
-- storing the necessary sql statements to commit and share.
saveUnsafeMigrations :: (MonadIO m, Functor m) => ReaderT SqlBackend m ()
saveUnsafeMigrations = do
    unsafe <- (L.filter fst) <$> parseMigration' migrateAll
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
248
    unless (L.null $ L.map snd unsafe) $ do
David L. L. Thomas's avatar
Bugfix  
David L. L. Thomas committed
249
        liftIO $ T.writeFile filename $ T.unlines $ L.map ((`snoc` ';') . snd) unsafe
Bryan Richter's avatar
Bryan Richter committed
250 251 252 253 254 255 256 257 258 259 260 261 262 263
        liftIO $ mapM_ (T.hPutStrLn stderr) unsafeMigMessages
  where
    filename = "migrations/migrate.unsafe"
    unsafeMigMessages =
      [ ""
      , "*** UNSAFE MIGRATIONS EXIST"
      , ""
      , "The application will now exit. But first, unsafe migrations have been"
      , "stored in «" <> filename <> "». Please review them, rename them"
      , "appropriately, and commit them with your change."
      , ""
      , "More information follows."
      , ""
      ]
David L. L. Thomas's avatar
David L. L. Thomas committed
264

David L. L. Thomas's avatar
David L. L. Thomas committed
265

266 267
migrateTriggers :: MonadIO m => ReaderT SqlBackend m ()
migrateTriggers = do
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
268
    runSql $ T.unlines
David L. L. Thomas's avatar
David L. L. Thomas committed
269 270 271
        [ "CREATE OR REPLACE FUNCTION log_role_event_trigger() RETURNS trigger AS $role_event$"
        , "    BEGIN"
        , "        IF (TG_OP = 'DELETE') THEN"
272
        , "            INSERT INTO role_event (ts, \"user\", role, project, added) SELECT now(), OLD.\"user\", OLD.role, OLD.project, 'f';"
David L. L. Thomas's avatar
David L. L. Thomas committed
273 274
        , "            RETURN OLD;"
        , "        ELSIF (TG_OP = 'INSERT') THEN"
275
        , "            INSERT INTO role_event (ts, \"user\", role, project, added) SELECT now(), NEW.\"user\", NEW.role, NEW.project, 't';"
David L. L. Thomas's avatar
David L. L. Thomas committed
276 277 278 279 280 281 282
        , "            RETURN NEW;"
        , "        END IF;"
        , "        RETURN NULL;"
        , "    END;"
        , "$role_event$ LANGUAGE plpgsql;"
        ]

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
283
    runSql "DROP TRIGGER IF EXISTS role_event ON project_user_role;"
David L. L. Thomas's avatar
David L. L. Thomas committed
284

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
285
    runSql $ T.unlines
David L. L. Thomas's avatar
David L. L. Thomas committed
286 287 288 289 290
        [ "CREATE TRIGGER role_event"
        , "AFTER INSERT OR DELETE ON project_user_role"
        , "    FOR EACH ROW EXECUTE PROCEDURE log_role_event_trigger();"
        ]

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
291
    runSql $ T.unlines
David L. L. Thomas's avatar
David L. L. Thomas committed
292 293 294
        [ "CREATE OR REPLACE FUNCTION log_doc_event_trigger() RETURNS trigger AS $doc_event$"
        , "    BEGIN"
        , "        IF (TG_OP = 'INSERT' OR TG_OP = 'UPDATE') THEN"
295
        , "            INSERT INTO doc_event (ts, doc, blessed_version) SELECT now(), NEW.id, NEW.current_version;"
David L. L. Thomas's avatar
David L. L. Thomas committed
296 297 298 299 300 301 302
        , "            RETURN NEW;"
        , "        END IF;"
        , "        RETURN NULL;"
        , "    END;"
        , "$doc_event$ LANGUAGE plpgsql;"
        ]

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
303
    runSql "DROP TRIGGER IF EXISTS doc_event ON doc;"
David L. L. Thomas's avatar
David L. L. Thomas committed
304

David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
305
    runSql $ T.unlines
David L. L. Thomas's avatar
David L. L. Thomas committed
306 307 308 309 310
        [ "CREATE TRIGGER doc_event"
        , "AFTER INSERT OR DELETE ON doc"
        , "    FOR EACH ROW EXECUTE PROCEDURE log_doc_event_trigger();"
        ]

David L. L. Thomas's avatar
David L. L. Thomas committed
311
    return ()
David L. L. Thomas's avatar
David L. L. Thomas committed
312

Mitchell Rosen's avatar
Mitchell Rosen committed
313 314 315 316 317 318 319 320 321 322 323 324 325
--------------------------------------------------------------------------------
-- SnowdriftEvent handling

forkEventHandler :: App -> IO ()
forkEventHandler app@App{..} = void . forkIO . forever $ do
    threadDelay 1000000 -- Sleep for one second in between runs.
    handleNEvents 10     -- Handle up to 10 events per run.
  where
    handleNEvents :: Int -> IO ()
    handleNEvents 0 = return ()
    handleNEvents n = atomically (tryReadTChan appEventChan) >>= \case
        Nothing    -> return ()
        Just event -> do
326
            mapM_ (runDaemon app) (appEventHandlers settings <*> [event])
Mitchell Rosen's avatar
Mitchell Rosen committed
327
            handleNEvents (n-1)