stackage-server/Application.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
    ( makeApplication
    , getApplicationDev
    , makeFoundation
    ) where

import           Control.Concurrent (forkIO)
import           Control.Exception (catch)
import           Data.WebsiteContent
import           Import hiding (catch)
import           Language.Haskell.TH.Syntax (Loc(..))
import           Network.Wai (Middleware, responseLBS, rawPathInfo)
import           Network.Wai.Logger (clockDateCacher)
import           Network.Wai.Middleware.ForceSSL (forceSSL)
import           Network.Wai.Middleware.RequestLogger
    ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
    )
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import           System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, fromLogStr)
import qualified System.Random.MWC as MWC
import           Yesod.Core.Types (loggerSet, Logger (Logger))
import           Yesod.Default.Config
import           Yesod.Default.Handlers
import           Yesod.Default.Main
import           Yesod.GitRepo
import           System.Process (rawSystem)
import           Stackage.Database.Cron (loadFromS3)
import           Control.AutoUpdate

import qualified Echo

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import           Handler.Home
import           Handler.Snapshots
import           Handler.StackageHome
import           Handler.StackageIndex
import           Handler.StackageSdist
import           Handler.System
import           Handler.Haddock
import           Handler.Package
import           Handler.PackageList
import           Handler.Hoogle
import           Handler.BuildVersion
import           Handler.Sitemap
import           Handler.BuildPlan
import           Handler.Download
import           Handler.OldLinks
import           Handler.Feed
import           Handler.DownloadStack

-- 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

-- 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.
makeApplication :: Bool -- ^ Use Echo.
                -> AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication echo@True conf = do
   foundation <- makeFoundation echo conf
   app <- toWaiAppPlain foundation
   logWare <- mkRequestLogger def
       { destination = RequestLogger.Callback (const (return ()))
       }
   Echo.clear
   return (forceSSL' conf $ logWare (defaultMiddlewaresNoLogging app),logFunc)
 where logFunc (Loc filename' _pkg _mod (line,_) _) source level str =
           Echo.write (filename',line) (show source ++ ": " ++ show level ++ ": " ++ toStr str)
       toStr = unpack . decodeUtf8 . fromLogStr
makeApplication echo@False conf = do
    foundation <- makeFoundation echo conf
    -- Initialize the logging middleware
    logWare <- mkRequestLogger def
        { outputFormat =
            if development
                then Detailed True
                else Apache FromFallback
        , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation
        }
    -- Create the WAI application and apply middlewares
    app <- toWaiAppPlain foundation
    let logFunc = messageLoggerSource foundation (appLogger foundation)
        middleware = forceSSL' conf . nicerExceptions . logWare . defaultMiddlewaresNoLogging
    return (middleware app, logFunc)

forceSSL' :: AppConfig DefaultEnv Extra -> Middleware
forceSSL' ac app
    | extraForceSsl $ appExtra ac = \req send ->
        -- Don't force SSL for tarballs, to provide 00-index.tar.gz and package
        -- tarball access for cabal-install
        if ".tar.gz" `isSuffixOf` rawPathInfo req
            then app req send
            else forceSSL app req send
    | otherwise = app

nicerExceptions :: Middleware
nicerExceptions app req send = catch (app req send) $ \e -> do
    let text = "Exception thrown to Warp: " ++ tshow (e :: SomeException)
    putStrLn text
    send $ responseLBS status500 [("Content-Type", "text/plain")] $
        fromStrict $ encodeUtf8 text

-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App
makeFoundation useEcho conf = do
    let extra = appExtra conf
    manager <- newManager
    s <- staticSite

    loggerSet' <- if useEcho
                     then newFileLoggerSet defaultBufSize "/dev/null"
                     else newStdoutLoggerSet defaultBufSize
    (getter, _) <- clockDateCacher

    gen <- MWC.createSystemRandom

    websiteContent' <- if extraDevDownload extra
        then do
            void $ rawSystem "git"
                [ "clone"
                , "https://github.com/fpco/stackage-content.git"
                ]
            gitRepoDev "stackage-content" loadWebsiteContent
        else gitRepo
            "https://github.com/fpco/stackage-content.git"
            "master"
            loadWebsiteContent

    (stackageDatabase', refreshDB) <- loadFromS3 (extraDevDownload extra) manager

    -- Temporary workaround to force content updates regularly, until
    -- distribution of webhooks is handled via consul
    void $ forkIO $ forever $ void $ do
        threadDelay $ 1000 * 1000 * 60 * 5
        handleAny print refreshDB
        handleAny print $ grRefresh websiteContent'

    latestStackMatcher' <- mkAutoUpdate defaultUpdateSettings
        { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes
        , updateAction = getLatestMatcher manager
        }

    hoogleLock <- newMVar ()
    let logger = Yesod.Core.Types.Logger loggerSet' getter
        foundation = App
            { settings = conf
            , getStatic = s
            , httpManager = manager
            , appLogger = logger
            , genIO = gen
            , websiteContent = websiteContent'
            , stackageDatabase = stackageDatabase'
            , latestStackMatcher = latestStackMatcher'
            , appHoogleLock = hoogleLock
            }

    return foundation

-- for yesod devel
getApplicationDev :: Bool -> IO (Int, Application)
getApplicationDev useEcho =
    defaultDevelApp loader (fmap fst . makeApplication useEcho)
  where
    loader = Yesod.Default.Config.loadConfig (configSettings Development)
        { csParseExtra = parseExtra
        }