mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
Just need to actually write and run the cron job
This commit is contained in:
parent
7caaf7ba23
commit
a923a4e5ff
@ -28,7 +28,7 @@ import Yesod.Default.Main
|
||||
import Yesod.GitRepo
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Process (rawSystem)
|
||||
import Stackage.Database (createStackageDatabase, openStackageDatabase)
|
||||
import Stackage.Database.Cron (loadFromS3)
|
||||
|
||||
import qualified Echo
|
||||
|
||||
@ -134,16 +134,14 @@ makeFoundation useEcho conf = do
|
||||
"master"
|
||||
loadWebsiteContent
|
||||
|
||||
(stackageDatabase', refreshDB) <- loadFromS3
|
||||
|
||||
-- Temporary workaround to force content updates regularly, until
|
||||
-- distribution of webhooks is handled via consul
|
||||
void $ forkIO $ forever $ void $ tryAny $ do
|
||||
threadDelay $ 1000 * 1000 * 60 * 20
|
||||
grRefresh websiteContent'
|
||||
|
||||
let dbfile = "stackage.sqlite3"
|
||||
createStackageDatabase dbfile
|
||||
stackageDatabase' <- openStackageDatabase dbfile
|
||||
-- FIXME refresh this on a regular basis
|
||||
void $ forkIO $ forever $ void $ do
|
||||
handleAny print $ refreshDB manager
|
||||
threadDelay $ 1000 * 1000 * 60 * 5
|
||||
handleAny print $ grRefresh websiteContent'
|
||||
|
||||
env <- getEnvironment
|
||||
|
||||
|
||||
@ -9,9 +9,12 @@ import qualified Hoogle
|
||||
import Import
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
import Stackage.Database
|
||||
import qualified Stackage.Database.Cron as Cron
|
||||
|
||||
getHoogleDB :: SnapName -> Handler (Maybe FilePath)
|
||||
getHoogleDB _ = return Nothing -- FIXME
|
||||
getHoogleDB name = do
|
||||
app <- getYesod
|
||||
liftIO $ Cron.getHoogleDB (httpManager app) name
|
||||
|
||||
getHoogleR :: SnapName -> Handler Html
|
||||
getHoogleR name = do
|
||||
|
||||
@ -28,6 +28,7 @@ module Stackage.Database
|
||||
, prettyName
|
||||
, getSnapshotsForPackage
|
||||
, getSnapshots
|
||||
, currentSchema
|
||||
) where
|
||||
|
||||
import Database.Sqlite (SqliteException)
|
||||
@ -393,7 +394,7 @@ prettyName name ghc =
|
||||
SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y]
|
||||
SNNightly d -> "Stackage Nightly " ++ tshow d
|
||||
|
||||
getAllPackages :: GetStackageDatabase m => m [(Text, Text, Text)]
|
||||
getAllPackages :: GetStackageDatabase m => m [(Text, Text, Text)] -- FIXME add information on whether included in LTS and Nightly
|
||||
getAllPackages = liftM (map toPair) $ run $ do
|
||||
E.select $ E.from $ \p -> do
|
||||
E.orderBy [E.asc $ p E.^. PackageName]
|
||||
|
||||
@ -1,13 +1,83 @@
|
||||
module Stackage.Database.Cron
|
||||
( stackageServerCron
|
||||
, loadFromS3
|
||||
, getHoogleDB
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Conduit
|
||||
import Stackage.Database
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Client.Conduit (bodyReaderSource)
|
||||
import Filesystem (rename)
|
||||
import Web.PathPieces (toPathPiece)
|
||||
import Filesystem (isFile)
|
||||
import Network.HTTP.Types (status200)
|
||||
|
||||
filename' :: Text
|
||||
filename' = concat
|
||||
[ "stackage-database-"
|
||||
, tshow currentSchema
|
||||
, ".sqlite3"
|
||||
]
|
||||
|
||||
keyName :: Text
|
||||
keyName = "stackage-database/" ++ filename'
|
||||
|
||||
url :: Text
|
||||
url = "https://s3.amazonaws.com/haddock.stackage.org/" ++ keyName
|
||||
|
||||
-- | Provides an action to be used to refresh the file from S3.
|
||||
loadFromS3 :: IO (StackageDatabase, Manager -> IO ())
|
||||
loadFromS3 = do
|
||||
let fp = fpFromText filename'
|
||||
fptmp = fp <.> "tmp"
|
||||
req <- parseUrl $ unpack url
|
||||
let download man = withResponse req man $ \res -> do
|
||||
runResourceT
|
||||
$ bodyReaderSource (responseBody res)
|
||||
$$ sinkFile fptmp
|
||||
rename fptmp fp
|
||||
db <- openStackageDatabase fp
|
||||
return (db, download)
|
||||
|
||||
stackageServerCron :: IO ()
|
||||
stackageServerCron = error "FIXME: stackageServerCron not implemented"
|
||||
|
||||
|
||||
hoogleKey :: SnapName -> Text
|
||||
hoogleKey name = concat
|
||||
[ "hoogle/"
|
||||
, toPathPiece name
|
||||
, "/"
|
||||
, VERSION_hoogle
|
||||
, ".hoo"
|
||||
]
|
||||
|
||||
hoogleUrl :: SnapName -> Text
|
||||
hoogleUrl n = "https://s3.amazonaws.com/haddock.stackage.org/" ++ hoogleKey n
|
||||
|
||||
getHoogleDB :: Manager -> SnapName -> IO (Maybe FilePath)
|
||||
getHoogleDB man name = do
|
||||
let fp = fpFromText $ hoogleKey name
|
||||
fptmp = fp <.> "tmp"
|
||||
exists <- isFile fp
|
||||
if exists
|
||||
then return $ Just fp
|
||||
else do
|
||||
req' <- parseUrl $ unpack $ hoogleUrl name
|
||||
let req = req' { checkStatus = \_ _ _ -> Nothing }
|
||||
withResponse req man $ \res -> if responseStatus res == status200
|
||||
then do
|
||||
runResourceT $ bodyReaderSource (responseBody res)
|
||||
$$ sinkFile fptmp
|
||||
rename fptmp fp
|
||||
return $ Just fp
|
||||
else do
|
||||
mapM brRead res >>= print
|
||||
return Nothing
|
||||
|
||||
{-
|
||||
createStackageDatabase dbfile
|
||||
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
|
||||
|
||||
@ -173,6 +173,8 @@ library
|
||||
, persistent-sqlite
|
||||
, stackage-metadata >= 0.2
|
||||
, filepath
|
||||
, http-client
|
||||
, http-types
|
||||
|
||||
executable stackage-server
|
||||
if flag(library-only)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user