mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-15 13:48:29 +01:00
Merge branch 'ghc-7.10' of https://github.com/zudov/stackage-server into zudov-ghc-7.10
Conflicts: Stackage/Database/Cron.hs
This commit is contained in:
Michael Snoyman
commit
4cec606fb0
@ -22,7 +22,7 @@ supportedArches = [minBound .. maxBound]
|
||||
readGhcLinks :: FilePath -> IO GhcLinks
|
||||
readGhcLinks dir = do
|
||||
let ghcMajorVersionsPath = dir </> "supported-ghc-major-versions.yaml"
|
||||
Yaml.decodeFile (fpToString ghcMajorVersionsPath) >>= \case
|
||||
Yaml.decodeFile ghcMajorVersionsPath >>= \case
|
||||
Nothing -> return $ GhcLinks HashMap.empty
|
||||
Just (ghcMajorVersions :: [GhcMajorVersion]) -> do
|
||||
let opts =
|
||||
@ -35,9 +35,9 @@ readGhcLinks dir = do
|
||||
let verText = ghcMajorVersionToText ver
|
||||
fileName = "ghc-" <> verText <> "-links.yaml"
|
||||
path = dir
|
||||
</> fpFromText (toPathPiece arch)
|
||||
</> fpFromText fileName
|
||||
whenM (liftIO $ isFile path) $ do
|
||||
text <- liftIO $ readTextFile path
|
||||
</> unpack (toPathPiece arch)
|
||||
</> unpack fileName
|
||||
whenM (liftIO $ isFile (fromString path)) $ do
|
||||
text <- liftIO $ readTextFile (fromString path)
|
||||
modify (HashMap.insert (arch, ver) text)
|
||||
return $ GhcLinks hashMap
|
||||
|
||||
@ -9,15 +9,15 @@ getBuildVersionR :: Handler Text
|
||||
getBuildVersionR = return $ pack $(do
|
||||
let headFile = ".git/HEAD"
|
||||
qAddDependentFile headFile
|
||||
ehead <- qRunIO $ tryIO $ readFile $ fpFromString headFile
|
||||
ehead <- qRunIO $ tryIO $ readFile $ headFile
|
||||
case decodeUtf8 <$> ehead of
|
||||
Left e -> lift $ ".git/HEAD not read: " ++ show e
|
||||
Right raw ->
|
||||
case takeWhile (/= '\n') <$> stripPrefix "ref: " raw of
|
||||
Nothing -> lift $ ".git/HEAD not in expected format: " ++ show raw
|
||||
Just fp' -> do
|
||||
let fp = ".git" </> fpFromText fp'
|
||||
qAddDependentFile $ fpToString fp
|
||||
let fp = ".git" </> unpack (fp' :: Text)
|
||||
qAddDependentFile fp
|
||||
bs <- qRunIO $ readFile fp
|
||||
isDirty <- qRunIO
|
||||
$ (/= ExitSuccess)
|
||||
|
||||
@ -34,7 +34,7 @@ getHoogleR name = do
|
||||
offset = (page - 1) * perPage
|
||||
mdatabasePath <- getHoogleDB name
|
||||
heDatabase <- case mdatabasePath of
|
||||
Just x -> return $ liftIO $ Hoogle.loadDatabase $ fpToString x
|
||||
Just x -> return $ liftIO $ Hoogle.loadDatabase x
|
||||
Nothing -> hoogleDatabaseNotAvailableFor name
|
||||
|
||||
mresults <- case mquery of
|
||||
@ -61,7 +61,7 @@ getHoogleDatabaseR name = do
|
||||
mdatabasePath <- getHoogleDB name
|
||||
case mdatabasePath of
|
||||
Nothing -> hoogleDatabaseNotAvailableFor name
|
||||
Just path -> sendFile "application/octet-stream" $ fpToString path
|
||||
Just path -> sendFile "application/octet-stream" path
|
||||
|
||||
hoogleDatabaseNotAvailableFor :: SnapName -> Handler a
|
||||
hoogleDatabaseNotAvailableFor name = (>>= sendResponse) $ defaultLayout $ do
|
||||
|
||||
@ -42,13 +42,13 @@ import Text.Markdown (Markdown (..))
|
||||
import System.Directory (removeFile)
|
||||
import Stackage.Database.Haddock
|
||||
import System.FilePath (takeBaseName, takeExtension)
|
||||
import ClassyPrelude.Conduit hiding (pi)
|
||||
import ClassyPrelude.Conduit hiding (pi, FilePath, (</>))
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
import Yesod.Form.Fields (Textarea (..))
|
||||
import Stackage.Database.Types
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import qualified Filesystem as F
|
||||
import Filesystem.Path (parent)
|
||||
import Filesystem.Path.CurrentOS (parent, filename, directory, FilePath, encodeString, (</>))
|
||||
import Data.Conduit.Process
|
||||
import Stackage.Types
|
||||
import Stackage.Metadata
|
||||
@ -158,18 +158,18 @@ sourceBuildPlans :: MonadResource m => FilePath -> Producer m (SnapName, FilePat
|
||||
sourceBuildPlans root = do
|
||||
forM_ ["lts-haskell", "stackage-nightly"] $ \repoName -> do
|
||||
dir <- liftIO $ cloneOrUpdate root "fpco" repoName
|
||||
sourceDirectory dir =$= concatMapMC (go Left)
|
||||
sourceDirectory (encodeString dir) =$= concatMapMC (go Left . fromString)
|
||||
let docdir = dir </> "docs"
|
||||
whenM (liftIO $ F.isDirectory docdir) $
|
||||
sourceDirectory docdir =$= concatMapMC (go Right)
|
||||
sourceDirectory (encodeString docdir) =$= concatMapMC (go Right . fromString)
|
||||
where
|
||||
go wrapper fp | Just name <- nameFromFP fp = liftIO $ do
|
||||
let bp = decodeFileEither (fpToString fp) >>= either throwM return
|
||||
let bp = decodeFileEither (encodeString fp) >>= either throwM return
|
||||
return $ Just (name, fp, wrapper bp)
|
||||
go _ _ = return Nothing
|
||||
|
||||
nameFromFP fp = do
|
||||
base <- stripSuffix ".yaml" $ fpToText $ filename fp
|
||||
base <- stripSuffix ".yaml" $ pack $ encodeString $ filename fp
|
||||
fromPathPiece base
|
||||
|
||||
cloneOrUpdate :: FilePath -> String -> String -> IO FilePath
|
||||
@ -184,18 +184,18 @@ cloneOrUpdate root org name = do
|
||||
return dest
|
||||
where
|
||||
url = "https://github.com/" ++ org ++ "/" ++ name ++ ".git"
|
||||
dest = root </> fpFromString name
|
||||
dest = root </> fromString name
|
||||
|
||||
runIn :: FilePath -> String -> [String] -> IO ()
|
||||
runIn dir cmd args =
|
||||
withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
|
||||
where
|
||||
cp = (proc cmd args) { cwd = Just $ fpToString dir }
|
||||
cp = (proc cmd args) { cwd = Just $ encodeString dir }
|
||||
|
||||
openStackageDatabase :: MonadIO m => FilePath -> m StackageDatabase
|
||||
openStackageDatabase fp = liftIO $ do
|
||||
F.createTree $ parent fp
|
||||
fmap StackageDatabase $ runNoLoggingT $ createSqlitePool (fpToText fp) 7
|
||||
fmap StackageDatabase $ runNoLoggingT $ createSqlitePool (pack $ encodeString fp) 7
|
||||
|
||||
getSchema :: FilePath -> IO (Maybe Int)
|
||||
getSchema fp = do
|
||||
@ -213,15 +213,15 @@ createStackageDatabase fp = liftIO $ do
|
||||
let schemaMatch = actualSchema == Just currentSchema
|
||||
unless schemaMatch $ do
|
||||
putStrLn $ "Current schema does not match actual schema: " ++ tshow (actualSchema, currentSchema)
|
||||
putStrLn $ "Deleting " ++ fpToText fp
|
||||
void $ tryIO $ removeFile $ fpToString fp
|
||||
putStrLn $ "Deleting " ++ pack (encodeString fp)
|
||||
void $ tryIO $ removeFile $ encodeString fp
|
||||
|
||||
StackageDatabase pool <- openStackageDatabase fp
|
||||
flip runSqlPool pool $ do
|
||||
runMigration migrateAll
|
||||
unless schemaMatch $ insert_ $ Schema currentSchema
|
||||
|
||||
root <- liftIO $ fmap (</> "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage"
|
||||
root <- liftIO $ fmap (</> fromString "database") $ fmap fromString $ getAppUserDataDirectory "stackage"
|
||||
F.createTree root
|
||||
runResourceT $ do
|
||||
putStrLn "Updating all-cabal-metadata repo"
|
||||
@ -253,7 +253,7 @@ createStackageDatabase fp = liftIO $ do
|
||||
let i = Imported sname typ
|
||||
eres <- insertBy i
|
||||
case eres of
|
||||
Left _ -> putStrLn $ "Skipping: " ++ fpToText fp'
|
||||
Left _ -> putStrLn $ "Skipping: " ++ tshow fp'
|
||||
Right _ -> action
|
||||
)
|
||||
flip runSqlPool pool $ mapM_ (flip rawExecute []) ["COMMIT", "VACUUM", "BEGIN"]
|
||||
@ -338,9 +338,9 @@ addPlan name fp bp = do
|
||||
[ "log"
|
||||
, "--format=%ad"
|
||||
, "--date=short"
|
||||
, fpToString $ filename fp
|
||||
, encodeString $ filename fp
|
||||
]
|
||||
cp = cp' { cwd = Just $ fpToString $ directory fp }
|
||||
cp = cp' { cwd = Just $ encodeString $ directory fp }
|
||||
t <- withCheckedProcess cp $ \ClosedStream out ClosedStream ->
|
||||
out $$ decodeUtf8C =$ foldC
|
||||
case readMay $ concat $ take 1 $ words t of
|
||||
|
||||
@ -16,7 +16,7 @@ import Network.HTTP.Client.Conduit (bodyReaderSource)
|
||||
import Filesystem (rename, removeTree, removeFile)
|
||||
import Web.PathPieces (toPathPiece)
|
||||
import Filesystem (isFile, createTree)
|
||||
import Filesystem.Path (parent)
|
||||
import Filesystem.Path.CurrentOS (parent, fromText, encodeString)
|
||||
import Control.Monad.State.Strict (StateT, get, put)
|
||||
import Network.HTTP.Types (status200)
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
@ -68,18 +68,18 @@ loadFromS3 develMode man = do
|
||||
writeTVar currSuffixVar $! x + 1
|
||||
return x
|
||||
|
||||
let fp = root </> fpFromText ("database-download-" ++ tshow suffix)
|
||||
let fp = root </> unpack ("database-download-" ++ tshow suffix)
|
||||
isInitial = suffix == 1
|
||||
toSkip <-
|
||||
if isInitial
|
||||
then do
|
||||
putStrLn $ "Checking if database exists: " ++ tshow fp
|
||||
doesFileExist $ fpToString fp
|
||||
doesFileExist fp
|
||||
else return False
|
||||
if toSkip
|
||||
then putStrLn "Skipping initial database download"
|
||||
else do
|
||||
putStrLn $ "Downloading database to " ++ fpToText fp
|
||||
putStrLn $ "Downloading database to " ++ pack fp
|
||||
withResponse req man $ \res ->
|
||||
runResourceT
|
||||
$ bodyReaderSource (responseBody res)
|
||||
@ -93,14 +93,14 @@ loadFromS3 develMode man = do
|
||||
|
||||
let update = do
|
||||
fp <- download
|
||||
db <- openStackageDatabase fp `onException` removeFile fp
|
||||
db <- openStackageDatabase (fromString fp) `onException` removeFile (fromString fp)
|
||||
void $ tryIO $ join $ atomically $ do
|
||||
writeTVar dbvar db
|
||||
oldKill <- readTVar killPrevVar
|
||||
writeTVar killPrevVar $ do
|
||||
-- give existing users a chance to clean up
|
||||
threadDelay $ 1000000 * 30
|
||||
void $ tryIO $ removeFile fp
|
||||
void $ tryIO $ removeFile (fromString fp)
|
||||
return oldKill
|
||||
|
||||
update
|
||||
@ -125,11 +125,11 @@ hoogleUrl n = concat
|
||||
getHoogleDB :: Bool -- ^ print exceptions?
|
||||
-> Manager -> SnapName -> IO (Maybe FilePath)
|
||||
getHoogleDB toPrint man name = do
|
||||
let fp = fpFromText $ hoogleKey name
|
||||
fptmp = fp <.> "tmp"
|
||||
let fp = fromText $ hoogleKey name
|
||||
fptmp = encodeString fp <.> "tmp"
|
||||
exists <- isFile fp
|
||||
if exists
|
||||
then return $ Just fp
|
||||
then return $ Just (encodeString fp)
|
||||
else do
|
||||
req' <- parseUrl $ unpack $ hoogleUrl name
|
||||
let req = req'
|
||||
@ -138,12 +138,12 @@ getHoogleDB toPrint man name = do
|
||||
}
|
||||
withResponse req man $ \res -> if responseStatus res == status200
|
||||
then do
|
||||
createTree $ parent fptmp
|
||||
createTree $ parent (fromString fptmp)
|
||||
runResourceT $ bodyReaderSource (responseBody res)
|
||||
$= ungzip
|
||||
$$ sinkFile fptmp
|
||||
rename fptmp fp
|
||||
return $ Just fp
|
||||
rename (fromString fptmp) fp
|
||||
return $ Just $ encodeString fp
|
||||
else do
|
||||
when toPrint $ mapM brRead res >>= print
|
||||
return Nothing
|
||||
@ -157,7 +157,7 @@ stackageServerCron = do
|
||||
env <- getEnv NorthVirginia Discover
|
||||
let upload :: FilePath -> Text -> IO ()
|
||||
upload fp key = do
|
||||
let fpgz = fpToString $ fp <.> "gz"
|
||||
let fpgz = fp <.> "gz"
|
||||
runResourceT $ sourceFile fp
|
||||
$$ compress 9 (WindowBits 31)
|
||||
=$ CB.sinkFile fpgz
|
||||
@ -171,9 +171,9 @@ stackageServerCron = do
|
||||
Left e -> error $ show (fp, key, e)
|
||||
Right _ -> putStrLn "Success"
|
||||
|
||||
let dbfp = fpFromText keyName
|
||||
let dbfp = fromText keyName
|
||||
createStackageDatabase dbfp
|
||||
upload dbfp keyName
|
||||
upload (encodeString dbfp) keyName
|
||||
|
||||
db <- openStackageDatabase dbfp
|
||||
|
||||
@ -200,33 +200,33 @@ stackageServerCron = do
|
||||
forM_ mfp' $ \fp -> do
|
||||
let key = hoogleKey name
|
||||
upload fp key
|
||||
let dest = fpFromText key
|
||||
createTree $ parent dest
|
||||
rename fp dest
|
||||
let dest = unpack key
|
||||
createTree $ parent (fromString dest)
|
||||
rename (fromString fp) (fromString dest)
|
||||
|
||||
createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath)
|
||||
createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
|
||||
req' <- parseUrl $ unpack tarUrl
|
||||
let req = req' { decompress = const True }
|
||||
|
||||
unlessM (isFile tarFP) $ withResponse req man $ \res -> do
|
||||
unlessM (isFile (fromString tarFP)) $ withResponse req man $ \res -> do
|
||||
let tmp = tarFP <.> "tmp"
|
||||
createTree $ parent tmp
|
||||
createTree $ parent (fromString tmp)
|
||||
runResourceT $ bodyReaderSource (responseBody res)
|
||||
$$ sinkFile tmp
|
||||
rename tmp tarFP
|
||||
rename (fromString tmp) (fromString tarFP)
|
||||
|
||||
void $ tryIO $ removeTree bindir
|
||||
void $ tryIO $ removeFile outname
|
||||
createTree bindir
|
||||
void $ tryIO $ removeTree (fromString bindir)
|
||||
void $ tryIO $ removeFile (fromString outname)
|
||||
createTree (fromString bindir)
|
||||
|
||||
dbs <- runResourceT
|
||||
$ sourceTarFile False (fpToString tarFP)
|
||||
$ sourceTarFile False tarFP
|
||||
$$ evalStateC 1 (mapMC (singleDB db name bindir))
|
||||
=$ sinkList
|
||||
|
||||
putStrLn "Merging databases..."
|
||||
Hoogle.mergeDatabase (map fpToString $ catMaybes dbs) (fpToString outname)
|
||||
Hoogle.mergeDatabase (catMaybes dbs) outname
|
||||
putStrLn "Merge done"
|
||||
|
||||
return $ Just outname
|
||||
@ -237,7 +237,7 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
|
||||
|
||||
tarKey = toPathPiece name ++ "/hoogle/orig.tar"
|
||||
tarUrl = "https://s3.amazonaws.com/haddock.stackage.org/" ++ tarKey
|
||||
tarFP = root </> fpFromText tarKey
|
||||
tarFP = root </> unpack tarKey
|
||||
|
||||
singleDB :: StackageDatabase
|
||||
-> SnapName
|
||||
@ -260,7 +260,7 @@ singleDB db sname bindir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
|
||||
Just (Entity _ sp) -> do
|
||||
let ver = snapshotPackageVersion sp
|
||||
pkgver = concat [pkg, "-", ver]
|
||||
out = bindir </> fpFromString (show idx) <.> "hoo"
|
||||
out = bindir </> show idx <.> "hoo"
|
||||
src' = unlines
|
||||
$ haddockHacks (Just $ unpack docsUrl)
|
||||
$ lines
|
||||
@ -274,7 +274,7 @@ singleDB db sname bindir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
|
||||
, "/index.html"
|
||||
]
|
||||
|
||||
_errs <- liftIO $ Hoogle.createDatabase "" Hoogle.Haskell [] src' $ fpToString out
|
||||
_errs <- liftIO $ Hoogle.createDatabase "" Hoogle.Haskell [] src' out
|
||||
|
||||
return $ Just out
|
||||
singleDB _ _ _ _ = return Nothing
|
||||
|
||||
@ -5,12 +5,12 @@ module Stackage.Database.Haddock
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import qualified Documentation.Haddock.Parser as Haddock
|
||||
import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..))
|
||||
import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..), MetaDoc(..))
|
||||
import ClassyPrelude.Conduit
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
|
||||
renderHaddock :: Text -> Html
|
||||
renderHaddock = hToHtml . Haddock.toRegular . Haddock.parseParas . unpack
|
||||
renderHaddock = hToHtml . Haddock.toRegular . _doc . Haddock.parseParas . unpack
|
||||
|
||||
-- | Convert a Haddock doc to HTML.
|
||||
hToHtml :: DocH String String -> Html
|
||||
|
||||
1065
cabal.config
1065
cabal.config
File diff suppressed because it is too large
Load Diff
@ -1,5 +1,4 @@
|
||||
packages:
|
||||
- .
|
||||
extra-deps:
|
||||
- stackage-metadata-0.3.0.0
|
||||
resolver: lts-2.17
|
||||
extra-deps: []
|
||||
resolver: lts-3.2
|
||||
|
||||
@ -93,7 +93,7 @@ library
|
||||
, blaze-markup >= 0.6
|
||||
, byteable
|
||||
, bytestring >= 0.9
|
||||
, classy-prelude-yesod >= 0.9.2 && < 0.12
|
||||
, classy-prelude-yesod >= 0.9.2
|
||||
, conduit >= 1.0
|
||||
, conduit-extra
|
||||
, cryptohash
|
||||
@ -127,13 +127,13 @@ library
|
||||
, wai-extra >= 2.1
|
||||
, wai-logger >= 2.1
|
||||
, warp >= 2.1
|
||||
, xml-conduit < 1.3
|
||||
, xml-conduit
|
||||
, yaml >= 0.8
|
||||
, yesod >= 1.2.5
|
||||
, yesod-auth >= 1.3
|
||||
, yesod-core >= 1.2.19
|
||||
, yesod-form >= 1.3.14
|
||||
, yesod-static >= 1.2 && < 1.5
|
||||
, yesod-static >= 1.2
|
||||
, zlib
|
||||
, unordered-containers
|
||||
, hashable
|
||||
@ -150,9 +150,9 @@ library
|
||||
, markdown >= 0.1.13
|
||||
, formatting
|
||||
, blaze-html
|
||||
, haddock-library
|
||||
, haddock-library >= 1.2.0
|
||||
, async
|
||||
, yesod-gitrepo >= 0.1.1 && < 0.2
|
||||
, yesod-gitrepo >= 0.1.1
|
||||
, hoogle
|
||||
, spoon
|
||||
, deepseq
|
||||
|
||||
Loading…
Reference in New Issue
Block a user