diff --git a/Application.hs b/Application.hs index bc449da..46afd0f 100644 --- a/Application.hs +++ b/Application.hs @@ -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 diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index 19a2958..a60db52 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -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 diff --git a/Stackage/Database.hs b/Stackage/Database.hs index 13c5208..3657218 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -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] diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index df3ec9e..a183428 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -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) diff --git a/stackage-server.cabal b/stackage-server.cabal index ccb9592..e00d6dd 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -173,6 +173,8 @@ library , persistent-sqlite , stackage-metadata >= 0.2 , filepath + , http-client + , http-types executable stackage-server if flag(library-only)