mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 12:18:29 +01:00
398 lines
15 KiB
Haskell
398 lines
15 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Application
|
|
( makeApplication
|
|
, getApplicationDev
|
|
, makeFoundation
|
|
, cabalLoaderMain
|
|
) where
|
|
|
|
import qualified Aws
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Exception (catch)
|
|
import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr)
|
|
import Data.BlobStore (fileStore, storeWrite, cachedS3Store)
|
|
import Data.Hackage
|
|
import Data.Unpacking (newDocUnpacker, createHoogleDatabases)
|
|
import Data.WebsiteContent
|
|
import Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO)
|
|
import Data.Time (diffUTCTime)
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Persist
|
|
import Filesystem (getModified, removeTree)
|
|
import Import hiding (catch)
|
|
import Language.Haskell.TH.Syntax (Loc(..))
|
|
import Network.Wai (Middleware, responseLBS)
|
|
import Network.Wai.Logger (clockDateCacher)
|
|
import Network.Wai.Middleware.RequestLogger
|
|
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
|
|
)
|
|
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
|
|
import Settings
|
|
import System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, flushLogStr, 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.Environment (getEnvironment)
|
|
import Data.BlobStore (HasBlobStore (..), BlobStore)
|
|
import System.IO (hSetBuffering, BufferMode (LineBuffering))
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.Text as T
|
|
import System.Process (rawSystem)
|
|
|
|
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.Profile
|
|
import Handler.Email
|
|
import Handler.ResetToken
|
|
import Handler.UploadStackage
|
|
import Handler.StackageHome
|
|
import Handler.StackageIndex
|
|
import Handler.StackageSdist
|
|
import Handler.Aliases
|
|
import Handler.Alias
|
|
import Handler.Progress
|
|
import Handler.System
|
|
import Handler.Haddock
|
|
import Handler.Package
|
|
import Handler.PackageList
|
|
import Handler.CompressorStatus
|
|
import Handler.Tag
|
|
import Handler.BannedTags
|
|
import Handler.RefreshDeprecated
|
|
import Handler.UploadV2
|
|
import Handler.Hoogle
|
|
import Handler.BuildVersion
|
|
import Handler.PackageCounts
|
|
|
|
-- 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 (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 = nicerExceptions . logWare . defaultMiddlewaresNoLogging
|
|
return (middleware app, logFunc)
|
|
|
|
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
|
|
|
|
getDbConf :: AppConfig DefaultEnv Extra -> IO Settings.PersistConf
|
|
getDbConf conf =
|
|
withYamlEnvironment "config/postgresql.yml" (appEnv conf)
|
|
Database.Persist.loadConfig >>=
|
|
Database.Persist.applyEnv
|
|
|
|
loadBlobStore :: Manager -> AppConfig DefaultEnv Extra -> IO (BlobStore StoreKey)
|
|
loadBlobStore manager conf =
|
|
case storeConfig $ appExtra conf of
|
|
BSCFile root -> return $ fileStore root
|
|
BSCAWS root access secret bucket prefix -> do
|
|
creds <- Aws.Credentials
|
|
<$> pure (encodeUtf8 access)
|
|
<*> pure (encodeUtf8 secret)
|
|
<*> newIORef []
|
|
<*> pure Nothing
|
|
return $ cachedS3Store root creds bucket prefix manager
|
|
|
|
-- | Loads up any necessary settings, creates your foundation datatype, and
|
|
-- performs some initialization.
|
|
makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App
|
|
makeFoundation useEcho conf = do
|
|
manager <- newManager
|
|
s <- staticSite
|
|
dbconf <- getDbConf conf
|
|
p <- Database.Persist.createPoolConfig dbconf
|
|
|
|
loggerSet' <- if useEcho
|
|
then newFileLoggerSet defaultBufSize "/dev/null"
|
|
else newStdoutLoggerSet defaultBufSize
|
|
(getter, _) <- clockDateCacher
|
|
|
|
gen <- MWC.createSystemRandom
|
|
|
|
blobStore' <- loadBlobStore manager conf
|
|
|
|
let haddockRootDir' = "/tmp/stackage-server-haddocks2"
|
|
widgetCache' <- newIORef mempty
|
|
|
|
websiteContent' <- if development
|
|
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
|
|
|
|
env <- getEnvironment
|
|
|
|
let runDB' :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a
|
|
runDB' = flip (Database.Persist.runPool dbconf) p
|
|
docUnpacker <- newDocUnpacker haddockRootDir' blobStore' runDB'
|
|
|
|
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
|
foundation = App
|
|
{ settings = conf
|
|
, getStatic = s
|
|
, connPool = p
|
|
, httpManager = manager
|
|
, persistConfig = dbconf
|
|
, appLogger = logger
|
|
, genIO = gen
|
|
, blobStore = blobStore'
|
|
, haddockRootDir = haddockRootDir'
|
|
, appDocUnpacker = docUnpacker
|
|
, widgetCache = widgetCache'
|
|
, websiteContent = websiteContent'
|
|
}
|
|
|
|
let urlRender' = yesodRender foundation (appRoot conf)
|
|
|
|
-- Perform database migration using our application's logging settings.
|
|
when (lookup "STACKAGE_SKIP_MIGRATION" env /= Just "1") $
|
|
runResourceT $
|
|
flip runReaderT gen $
|
|
flip runLoggingT (messageLoggerSource foundation logger) $
|
|
flip (Database.Persist.runPool dbconf) p $ do
|
|
runMigration migrateAll
|
|
checkMigration 1 fixSnapSlugs
|
|
checkMigration 2 setCorePackages
|
|
|
|
|
|
let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0"
|
|
hoogleGen = lookup "STACKAGE_HOOGLE_GEN" env /= Just "0"
|
|
forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
|
|
loadCabalFiles' = appLoadCabalFiles updateDB forceUpdate foundation dbconf p
|
|
|
|
-- Start the cabal file loader
|
|
ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
|
|
$logInfoS "CLEANUP" "Cleaning up /tmp"
|
|
now <- liftIO getCurrentTime
|
|
runResourceT $ sourceDirectory "/tmp" $$ mapM_C (cleanupTemp now)
|
|
$logInfoS "CLEANUP" "Cleaning up complete"
|
|
|
|
loadCabalFiles'
|
|
|
|
when hoogleGen $ liftIO $ createHoogleDatabases blobStore' runDB' putStrLn urlRender'
|
|
|
|
liftIO $ threadDelay $ 30 * 60 * 1000000
|
|
return foundation
|
|
where ifRunCabalLoader m =
|
|
if cabalFileLoader
|
|
then void m
|
|
else return ()
|
|
|
|
data CabalLoaderEnv = CabalLoaderEnv
|
|
{ cleSettings :: !(AppConfig DefaultEnv Extra)
|
|
, cleBlobStore :: !(BlobStore StoreKey)
|
|
, cleManager :: !Manager
|
|
}
|
|
|
|
instance HasHackageRoot CabalLoaderEnv where
|
|
getHackageRoot = hackageRoot . appExtra . cleSettings
|
|
instance HasBlobStore CabalLoaderEnv StoreKey where
|
|
getBlobStore = cleBlobStore
|
|
instance HasHttpManager CabalLoaderEnv where
|
|
getHttpManager = cleManager
|
|
|
|
cabalLoaderMain :: IO ()
|
|
cabalLoaderMain = do
|
|
conf <- fromArgs parseExtra
|
|
dbconf <- getDbConf conf
|
|
pool <- Database.Persist.createPoolConfig dbconf
|
|
manager <- newManager
|
|
bs <- loadBlobStore manager conf
|
|
hSetBuffering stdout LineBuffering
|
|
env <- getEnvironment
|
|
let forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
|
|
flip runLoggingT logFunc $ appLoadCabalFiles
|
|
True -- update database?
|
|
forceUpdate
|
|
CabalLoaderEnv
|
|
{ cleSettings = conf
|
|
, cleBlobStore = bs
|
|
, cleManager = manager
|
|
}
|
|
dbconf
|
|
pool
|
|
|
|
let foundation = App
|
|
{ settings = conf
|
|
, getStatic = error "getStatic"
|
|
, connPool = pool
|
|
, httpManager = manager
|
|
, persistConfig = dbconf
|
|
, appLogger = error "appLogger"
|
|
, genIO = error "genIO"
|
|
, blobStore = bs
|
|
, haddockRootDir = error "haddockRootDir"
|
|
, appDocUnpacker = error "appDocUnpacker"
|
|
, widgetCache = error "widgetCache"
|
|
, websiteContent = error "websiteContent"
|
|
}
|
|
createHoogleDatabases
|
|
bs
|
|
(flip (Database.Persist.runPool dbconf) pool)
|
|
putStrLn
|
|
(yesodRender foundation (appRoot conf))
|
|
where
|
|
logFunc loc src level str
|
|
| level > LevelDebug = S.hPutStr stdout $ fromLogStr $ defaultLogStr loc src level str
|
|
| otherwise = return ()
|
|
|
|
appLoadCabalFiles :: ( PersistConfig c
|
|
, PersistConfigBackend c ~ SqlPersistT
|
|
, HasHackageRoot env
|
|
, HasBlobStore env StoreKey
|
|
, HasHttpManager env
|
|
)
|
|
=> Bool -- ^ update database?
|
|
-> Bool -- ^ force update?
|
|
-> env
|
|
-> c
|
|
-> PersistConfigPool c
|
|
-> LoggingT IO ()
|
|
appLoadCabalFiles updateDB forceUpdate env dbconf p = do
|
|
eres <- tryAny $ flip runReaderT env $ do
|
|
let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
|
|
-> ReaderT env (LoggingT IO) a
|
|
runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p
|
|
let toMDPair (E.Value name, E.Value version, E.Value hash') =
|
|
(name, (version, hash'))
|
|
metadata0 <- fmap (mapFromList . map toMDPair)
|
|
$ runDB' $ E.select $ E.from $ \m -> return
|
|
( m E.^. MetadataName
|
|
, m E.^. MetadataVersion
|
|
, m E.^. MetadataHash
|
|
)
|
|
UploadState _ newMD <- loadCabalFiles updateDB forceUpdate metadata0
|
|
$logInfo $ "Updating metadatas: " ++ tshow (length newMD)
|
|
runDB' $ do
|
|
let newMD' = toList newMD
|
|
deleteWhere [MetadataName <-. map metadataName newMD']
|
|
insertMany_ newMD'
|
|
forM_ newMD' $ \md -> do
|
|
deleteWhere [DependencyUser ==. metadataName md]
|
|
insertMany_ $ flip map (metadataDeps md) $ \dep ->
|
|
Dependency (PackageName dep) (metadataName md)
|
|
case eres of
|
|
Left e -> $logError $ tshow e
|
|
Right () -> return ()
|
|
|
|
cleanupTemp :: UTCTime -> FilePath -> ResourceT (LoggingT IO) ()
|
|
cleanupTemp now fp
|
|
| any (`isPrefixOf` name) prefixes = handleAny ($logError . tshow) $ do
|
|
modified <- liftIO $ getModified fp
|
|
if (diffUTCTime now modified > 60 * 60)
|
|
then do
|
|
$logInfoS "CLEANUP" $ "Removing temp directory: " ++ fpToText fp
|
|
liftIO $ removeTree fp
|
|
$logInfoS "CLEANUP" $ "Temp directory deleted: " ++ fpToText fp
|
|
else $logInfoS "CLEANUP" $ "Ignoring recent entry: " ++ fpToText fp
|
|
| otherwise = $logInfoS "CLEANUP" $ "Ignoring unmatched path: " ++ fpToText fp
|
|
where
|
|
name = fpToText $ filename fp
|
|
prefixes = asVector $ pack
|
|
[ "hackage-index"
|
|
, "createview"
|
|
, "build00index."
|
|
, "newindex"
|
|
]
|
|
|
|
-- 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
|
|
}
|
|
|
|
checkMigration :: MonadIO m
|
|
=> Int
|
|
-> ReaderT SqlBackend m ()
|
|
-> ReaderT SqlBackend m ()
|
|
checkMigration num f = do
|
|
eres <- insertBy $ Migration num
|
|
case eres of
|
|
Left _ -> return ()
|
|
Right _ -> f
|
|
|
|
fixSnapSlugs :: (MonadResource m, HasGenIO env, MonadReader env m)
|
|
=> ReaderT SqlBackend m ()
|
|
fixSnapSlugs =
|
|
selectSource [] [Asc StackageUploaded] $$ mapM_C go
|
|
where
|
|
go (Entity sid Stackage {..}) =
|
|
loop (1 :: Int)
|
|
where
|
|
base = T.replace "haskell platform" "hp"
|
|
$ T.replace "stackage build for " ""
|
|
$ toLower stackageTitle
|
|
loop 50 = error "fixSnapSlugs can't find a good slug"
|
|
loop i = do
|
|
slug' <- lift $ safeMakeSlug base $ if i == 1 then False else True
|
|
let slug = SnapSlug slug'
|
|
ms <- getBy $ UniqueSnapshot slug
|
|
case ms of
|
|
Nothing -> update sid [StackageSlug =. slug]
|
|
Just _ -> loop (i + 1)
|
|
|
|
setCorePackages :: MonadIO m => ReaderT SqlBackend m ()
|
|
setCorePackages =
|
|
updateWhere
|
|
[ PackageName' <-. defaultCorePackages
|
|
, PackageCore ==. Nothing
|
|
]
|
|
[PackageCore =. Just True]
|
|
where
|
|
defaultCorePackages = map PackageName $ words =<<
|
|
[ "ghc hoopl bytestring unix haskeline Cabal base time xhtml"
|
|
, "haskell98 hpc filepath process array integer-gmp bin-package-db"
|
|
, "containers haskell2010 binary ghc-prim old-time old-locale rts"
|
|
, "terminfo transformers deepseq pretty template-haskell directory"
|
|
]
|