stackage-server/Stackage/Database/Cron.hs

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)
import           Network.AWS                   (Credentials (Discover),
                                                Region (NorthVirginia), getEnv,
                                                send, sourceFileIO)
import           Network.AWS.S3                (ObjectCannedACL (PublicRead),
                                                poACL,
                                                putObject)
import Control.Lens (set)
import qualified Data.Conduit.Binary as CB
import           Data.Conduit.Zlib             (WindowBits (WindowBits),
                                                compress)

filename' :: Text
filename' = concat
    [ "stackage-database-"
    , tshow currentSchema
    , ".sqlite3"
    ]

keyName :: Text
keyName = "stackage-database/" ++ filename'

url :: Text
url = concat
    [ "https://s3.amazonaws.com/haddock.stackage.org/"
    , keyName
    , ".gz"
    ]

-- | Provides an action to be used to refresh the file from S3.
loadFromS3 :: IO (StackageDatabase, Manager -> IO ())
loadFromS3 = do
    let fp = fpFromText keyName
        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)

hoogleKey :: SnapName -> Text
hoogleKey name = concat
    [ "hoogle/"
    , toPathPiece name
    , "/"
    , VERSION_hoogle
    , ".hoo"
    ]

hoogleUrl :: SnapName -> Text
hoogleUrl n = concat
    [ "https://s3.amazonaws.com/haddock.stackage.org/"
    , hoogleKey n
    , ".gz"
    ]

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

stackageServerCron :: IO ()
stackageServerCron = do
    env <- getEnv NorthVirginia Discover
    let upload fp key = do
            let fpgz = fpToString $ fp <.> "gz"
            runResourceT $ sourceFile fp
                        $$ compress 9 (WindowBits 31)
                        =$ CB.sinkFile fpgz
            body <- sourceFileIO fpgz
            let po = 
                      set poACL (Just PublicRead)
                   $  putObject body "haddock.stackage.org" key
            eres <- runResourceT $ send env po
            case eres of
                Left e -> error $ show (fp, key, e)
                Right _ -> return ()

    let dbfp = fpFromText keyName
    createStackageDatabase dbfp
    upload dbfp keyName

{-
    createStackageDatabase dbfile

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 ()
        -}


-}