Browse Source

Beginning of stackage-server-cron

simpler
Michael Snoyman 7 years ago
parent
commit
a0d2703738
  1. 98
      Application.hs
  2. 77
      Stackage/Database/Cron.hs
  3. 4
      app/cabal-loader.hs
  4. 4
      app/stackage-server-cron.hs
  5. 12
      stackage-server.cabal

98
Application.hs

@ -3,19 +3,13 @@ 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 Control.Monad.Logger (runLoggingT)
import Data.WebsiteContent
import Data.Streaming.Network (bindPortTCP)
import Data.Time (diffUTCTime)
import qualified Database.Esqueleto as E
import qualified Database.Persist
import Filesystem (getModified, removeTree, isFile)
import Import hiding (catch)
import Language.Haskell.TH.Syntax (Loc(..))
import Network.Wai (Middleware, responseLBS)
@ -33,9 +27,6 @@ import Yesod.Default.Handlers
import Yesod.Default.Main
import Yesod.GitRepo
import System.Environment (getEnvironment)
import System.IO (hSetBuffering, BufferMode (LineBuffering))
import qualified Data.ByteString as S
import qualified Data.Text as T
import System.Process (rawSystem)
import Stackage.Database (createStackageDatabase, openStackageDatabase)
@ -152,12 +143,10 @@ makeFoundation useEcho conf = do
let dbfile = "stackage.sqlite3"
createStackageDatabase dbfile
stackageDatabase' <- openStackageDatabase dbfile
-- FIXME refresh this on a regular basis
env <- getEnvironment
let runDB' :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a
runDB' = flip (Database.Persist.runPool dbconf) p
let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App
{ settings = conf
@ -171,8 +160,6 @@ makeFoundation useEcho conf = do
, stackageDatabase = stackageDatabase'
}
let urlRender' = yesodRender foundation (appRoot conf)
-- Perform database migration using our application's logging settings.
when (lookup "STACKAGE_SKIP_MIGRATION" env /= Just "1") $
runResourceT $
@ -185,78 +172,7 @@ makeFoundation useEcho conf = do
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"
return foundation
where ifRunCabalLoader m =
if cabalFileLoader
then void m
else return ()
data CabalLoaderEnv = CabalLoaderEnv
{ cleSettings :: !(AppConfig DefaultEnv Extra)
, cleManager :: !Manager
}
instance HasHackageRoot CabalLoaderEnv where
getHackageRoot = hackageRoot . appExtra . cleSettings
instance HasHttpManager CabalLoaderEnv where
getHttpManager = cleManager
cabalLoaderMain :: IO ()
cabalLoaderMain = do
-- Hacky approach instead of PID files
void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
error $ "cabal loader process already running, exiting"
error "cabalLoaderMain"
{- FIXME
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 ()
-}
-- for yesod devel
getApplicationDev :: Bool -> IO (Int, Application)
@ -267,11 +183,11 @@ getApplicationDev useEcho =
{ csParseExtra = parseExtra
}
checkMigration :: MonadIO m
=> Int
-> ReaderT SqlBackend m ()
-> ReaderT SqlBackend m ()
checkMigration num f = do
_checkMigration :: MonadIO m
=> Int
-> ReaderT SqlBackend m ()
-> ReaderT SqlBackend m ()
_checkMigration num f = do
eres <- insertBy $ Migration num
case eres of
Left _ -> return ()

77
Stackage/Database/Cron.hs

@ -0,0 +1,77 @@
module Stackage.Database.Cron
( stackageServerCron
) where
import ClassyPrelude.Conduit
stackageServerCron :: IO ()
stackageServerCron = error "FIXME: stackageServerCron not implemented"
{-
import Data.Streaming.Network (bindPortTCP)
data CabalLoaderEnv = CabalLoaderEnv
{ cleSettings :: !(AppConfig DefaultEnv Extra)
, cleManager :: !Manager
}
instance HasHackageRoot CabalLoaderEnv where
getHackageRoot = hackageRoot . appExtra . cleSettings
instance HasHttpManager CabalLoaderEnv where
getHttpManager = cleManager
cabalLoaderMain :: IO ()
cabalLoaderMain = do
-- Hacky approach instead of PID files
void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
error $ "cabal loader process already running, exiting"
error "cabalLoaderMain"
{- FIXME
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 ()
-}
-}

4
app/cabal-loader.hs

@ -1,4 +0,0 @@
import Application
main :: IO ()
main = cabalLoaderMain

4
app/stackage-server-cron.hs

@ -0,0 +1,4 @@
import Stackage.Database.Cron
main :: IO ()
main = stackageServerCron

12
stackage-server.cabal

@ -25,9 +25,13 @@ library
Data.GhcLinks
Data.WebsiteContent
Types
-- once stabilized, will likely move into its own package
Stackage.Database
Stackage.Database.Haddock
Stackage.Database.Types
Stackage.Database.Cron
Handler.Home
Handler.Snapshots
Handler.Profile
@ -182,15 +186,13 @@ executable stackage-server
ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N
executable cabal-loader-stackage
executable stackage-server-cron
if flag(library-only)
Buildable: False
main-is: cabal-loader.hs
main-is: stackage-server-cron.hs
hs-source-dirs: app
build-depends: base
, stackage-server
, yesod
build-depends: base, stackage-server
ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N

Loading…
Cancel
Save