haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-06 16:17:27 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge branch 'ghc-7.10' of https://github.com/zudov/stackage-server into zudov-ghc-7.10

Browse Source 
Conflicts:
	Stackage/Database/Cron.hs
This commit is contained in:
Michael Snoyman 2015-10-06 07:21:03 +03:00
commit 4cec606fb0
9 changed files with 63 additions and 1129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Data/GhcLinks.hs
View File

@ -22,7 +22,7 @@ supportedArches = [minBound .. maxBound]
readGhcLinks :: FilePath -> IO GhcLinks readGhcLinks :: FilePath -> IO GhcLinks
readGhcLinks dir = do readGhcLinks dir = do
let ghcMajorVersionsPath = dir </> "supported-ghc-major-versions.yaml" let ghcMajorVersionsPath = dir </> "supported-ghc-major-versions.yaml"
Yaml.decodeFile (fpToString ghcMajorVersionsPath) >>= \case Yaml.decodeFile ghcMajorVersionsPath >>= \case
Nothing -> return $ GhcLinks HashMap.empty Nothing -> return $ GhcLinks HashMap.empty
Just (ghcMajorVersions :: [GhcMajorVersion]) -> do Just (ghcMajorVersions :: [GhcMajorVersion]) -> do
let opts = let opts =
@ -35,9 +35,9 @@ readGhcLinks dir = do
let verText = ghcMajorVersionToText ver let verText = ghcMajorVersionToText ver
fileName = "ghc-" <> verText <> "-links.yaml" fileName = "ghc-" <> verText <> "-links.yaml"
path = dir path = dir
</> fpFromText (toPathPiece arch) </> unpack (toPathPiece arch)
</> fpFromText fileName </> unpack fileName
whenM (liftIO $ isFile path) $ do whenM (liftIO $ isFile (fromString path)) $ do
text <- liftIO $ readTextFile path text <- liftIO $ readTextFile (fromString path)
modify (HashMap.insert (arch, ver) text) modify (HashMap.insert (arch, ver) text)
return $ GhcLinks hashMap return $ GhcLinks hashMap

6
Handler/BuildVersion.hs
View File

@ -9,15 +9,15 @@ getBuildVersionR :: Handler Text
getBuildVersionR = return $ pack $(do getBuildVersionR = return $ pack $(do
let headFile = ".git/HEAD" let headFile = ".git/HEAD"
qAddDependentFile headFile qAddDependentFile headFile
ehead <- qRunIO $ tryIO $ readFile $ fpFromString headFile ehead <- qRunIO $ tryIO $ readFile $ headFile
case decodeUtf8 <$> ehead of case decodeUtf8 <$> ehead of
Left e -> lift $ ".git/HEAD not read: " ++ show e Left e -> lift $ ".git/HEAD not read: " ++ show e
Right raw -> Right raw ->
case takeWhile (/= '\n') <$> stripPrefix "ref: " raw of case takeWhile (/= '\n') <$> stripPrefix "ref: " raw of
Nothing -> lift $ ".git/HEAD not in expected format: " ++ show raw Nothing -> lift $ ".git/HEAD not in expected format: " ++ show raw
Just fp' -> do Just fp' -> do
let fp = ".git" </> fpFromText fp' let fp = ".git" </> unpack (fp' :: Text)
qAddDependentFile $ fpToString fp qAddDependentFile fp
bs <- qRunIO $ readFile fp bs <- qRunIO $ readFile fp
isDirty <- qRunIO isDirty <- qRunIO
$ (/= ExitSuccess) $ (/= ExitSuccess)

4
Handler/Hoogle.hs
View File

@ -34,7 +34,7 @@ getHoogleR name = do
offset = (page - 1) * perPage offset = (page - 1) * perPage
mdatabasePath <- getHoogleDB name mdatabasePath <- getHoogleDB name
heDatabase <- case mdatabasePath of heDatabase <- case mdatabasePath of
Just x -> return $ liftIO $ Hoogle.loadDatabase $ fpToString x Just x -> return $ liftIO $ Hoogle.loadDatabase x
Nothing -> hoogleDatabaseNotAvailableFor name Nothing -> hoogleDatabaseNotAvailableFor name
mresults <- case mquery of mresults <- case mquery of
@ -61,7 +61,7 @@ getHoogleDatabaseR name = do
mdatabasePath <- getHoogleDB name mdatabasePath <- getHoogleDB name
case mdatabasePath of case mdatabasePath of
Nothing -> hoogleDatabaseNotAvailableFor name Nothing -> hoogleDatabaseNotAvailableFor name
Just path -> sendFile "application/octet-stream" $ fpToString path Just path -> sendFile "application/octet-stream" path
hoogleDatabaseNotAvailableFor :: SnapName -> Handler a hoogleDatabaseNotAvailableFor :: SnapName -> Handler a
hoogleDatabaseNotAvailableFor name = (>>= sendResponse) $ defaultLayout $ do hoogleDatabaseNotAvailableFor name = (>>= sendResponse) $ defaultLayout $ do

30
Stackage/Database.hs
View File

@ -42,13 +42,13 @@ import Text.Markdown (Markdown (..))
import System.Directory (removeFile) import System.Directory (removeFile)
import Stackage.Database.Haddock import Stackage.Database.Haddock
import System.FilePath (takeBaseName, takeExtension) import System.FilePath (takeBaseName, takeExtension)
import ClassyPrelude.Conduit hiding (pi) import ClassyPrelude.Conduit hiding (pi, FilePath, (</>))
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
import Yesod.Form.Fields (Textarea (..)) import Yesod.Form.Fields (Textarea (..))
import Stackage.Database.Types import Stackage.Database.Types
import System.Directory (getAppUserDataDirectory) import System.Directory (getAppUserDataDirectory)
import qualified Filesystem as F import qualified Filesystem as F
import Filesystem.Path (parent) import Filesystem.Path.CurrentOS (parent, filename, directory, FilePath, encodeString, (</>))
import Data.Conduit.Process import Data.Conduit.Process
import Stackage.Types import Stackage.Types
import Stackage.Metadata import Stackage.Metadata
@ -158,18 +158,18 @@ sourceBuildPlans :: MonadResource m => FilePath -> Producer m (SnapName, FilePat
sourceBuildPlans root = do sourceBuildPlans root = do
forM_ ["lts-haskell", "stackage-nightly"] $ \repoName -> do forM_ ["lts-haskell", "stackage-nightly"] $ \repoName -> do
dir <- liftIO $ cloneOrUpdate root "fpco" repoName dir <- liftIO $ cloneOrUpdate root "fpco" repoName
sourceDirectory dir =$= concatMapMC (go Left) sourceDirectory (encodeString dir) =$= concatMapMC (go Left . fromString)
let docdir = dir </> "docs" let docdir = dir </> "docs"
whenM (liftIO $ F.isDirectory docdir) $ whenM (liftIO $ F.isDirectory docdir) $
sourceDirectory docdir =$= concatMapMC (go Right) sourceDirectory (encodeString docdir) =$= concatMapMC (go Right . fromString)
where where
go wrapper fp | Just name <- nameFromFP fp = liftIO $ do 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) return $ Just (name, fp, wrapper bp)
go _ _ = return Nothing go _ _ = return Nothing
nameFromFP fp = do nameFromFP fp = do
base <- stripSuffix ".yaml" $ fpToText $ filename fp base <- stripSuffix ".yaml" $ pack $ encodeString $ filename fp
fromPathPiece base fromPathPiece base
cloneOrUpdate :: FilePath -> String -> String -> IO FilePath cloneOrUpdate :: FilePath -> String -> String -> IO FilePath
@ -184,18 +184,18 @@ cloneOrUpdate root org name = do
return dest return dest
where where
url = "https://github.com/" ++ org ++ "/" ++ name ++ ".git" url = "https://github.com/" ++ org ++ "/" ++ name ++ ".git"
dest = root </> fpFromString name dest = root </> fromString name
runIn :: FilePath -> String -> [String] -> IO () runIn :: FilePath -> String -> [String] -> IO ()
runIn dir cmd args = runIn dir cmd args =
withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
where where
cp = (proc cmd args) { cwd = Just $ fpToString dir } cp = (proc cmd args) { cwd = Just $ encodeString dir }
openStackageDatabase :: MonadIO m => FilePath -> m StackageDatabase openStackageDatabase :: MonadIO m => FilePath -> m StackageDatabase
openStackageDatabase fp = liftIO $ do openStackageDatabase fp = liftIO $ do
F.createTree $ parent fp 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 :: FilePath -> IO (Maybe Int)
getSchema fp = do getSchema fp = do
@ -213,15 +213,15 @@ createStackageDatabase fp = liftIO $ do
let schemaMatch = actualSchema == Just currentSchema let schemaMatch = actualSchema == Just currentSchema
unless schemaMatch $ do unless schemaMatch $ do
putStrLn $ "Current schema does not match actual schema: " ++ tshow (actualSchema, currentSchema) putStrLn $ "Current schema does not match actual schema: " ++ tshow (actualSchema, currentSchema)
putStrLn $ "Deleting " ++ fpToText fp putStrLn $ "Deleting " ++ pack (encodeString fp)
void $ tryIO $ removeFile $ fpToString fp void $ tryIO $ removeFile $ encodeString fp
StackageDatabase pool <- openStackageDatabase fp StackageDatabase pool <- openStackageDatabase fp
flip runSqlPool pool $ do flip runSqlPool pool $ do
runMigration migrateAll runMigration migrateAll
unless schemaMatch $ insert_ $ Schema currentSchema 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 F.createTree root
runResourceT $ do runResourceT $ do
putStrLn "Updating all-cabal-metadata repo" putStrLn "Updating all-cabal-metadata repo"
@ -253,7 +253,7 @@ createStackageDatabase fp = liftIO $ do
let i = Imported sname typ let i = Imported sname typ
eres <- insertBy i eres <- insertBy i
case eres of case eres of
Left _ -> putStrLn $ "Skipping: " ++ fpToText fp' Left _ -> putStrLn $ "Skipping: " ++ tshow fp'
Right _ -> action Right _ -> action
) )
flip runSqlPool pool $ mapM_ (flip rawExecute []) ["COMMIT", "VACUUM", "BEGIN"] flip runSqlPool pool $ mapM_ (flip rawExecute []) ["COMMIT", "VACUUM", "BEGIN"]
@ -338,9 +338,9 @@ addPlan name fp bp = do
[ "log" [ "log"
, "--format=%ad" , "--format=%ad"
, "--date=short" , "--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 -> t <- withCheckedProcess cp $ \ClosedStream out ClosedStream ->
out $$ decodeUtf8C =$ foldC out $$ decodeUtf8C =$ foldC
case readMay $ concat $ take 1 $ words t of case readMay $ concat $ take 1 $ words t of

58
Stackage/Database/Cron.hs
View File

@ -16,7 +16,7 @@ import Network.HTTP.Client.Conduit (bodyReaderSource)
import Filesystem (rename, removeTree, removeFile) import Filesystem (rename, removeTree, removeFile)
import Web.PathPieces (toPathPiece) import Web.PathPieces (toPathPiece)
import Filesystem (isFile, createTree) import Filesystem (isFile, createTree)
import Filesystem.Path (parent) import Filesystem.Path.CurrentOS (parent, fromText, encodeString)
import Control.Monad.State.Strict (StateT, get, put) import Control.Monad.State.Strict (StateT, get, put)
import Network.HTTP.Types (status200) import Network.HTTP.Types (status200)
import Data.Streaming.Network (bindPortTCP) import Data.Streaming.Network (bindPortTCP)
@ -68,18 +68,18 @@ loadFromS3 develMode man = do
writeTVar currSuffixVar $! x + 1 writeTVar currSuffixVar $! x + 1
return x return x
let fp = root </> fpFromText ("database-download-" ++ tshow suffix) let fp = root </> unpack ("database-download-" ++ tshow suffix)
isInitial = suffix == 1 isInitial = suffix == 1
toSkip <- toSkip <-
if isInitial if isInitial
then do then do
putStrLn $ "Checking if database exists: " ++ tshow fp putStrLn $ "Checking if database exists: " ++ tshow fp
doesFileExist $ fpToString fp doesFileExist fp
else return False else return False
if toSkip if toSkip
then putStrLn "Skipping initial database download" then putStrLn "Skipping initial database download"
else do else do
putStrLn $ "Downloading database to " ++ fpToText fp putStrLn $ "Downloading database to " ++ pack fp
withResponse req man $ \res -> withResponse req man $ \res ->
runResourceT runResourceT
$ bodyReaderSource (responseBody res) $ bodyReaderSource (responseBody res)
@ -93,14 +93,14 @@ loadFromS3 develMode man = do
let update = do let update = do
fp <- download fp <- download
db <- openStackageDatabase fp `onException` removeFile fp db <- openStackageDatabase (fromString fp) `onException` removeFile (fromString fp)
void $ tryIO $ join $ atomically $ do void $ tryIO $ join $ atomically $ do
writeTVar dbvar db writeTVar dbvar db
oldKill <- readTVar killPrevVar oldKill <- readTVar killPrevVar
writeTVar killPrevVar $ do writeTVar killPrevVar $ do
-- give existing users a chance to clean up -- give existing users a chance to clean up
threadDelay $ 1000000 * 30 threadDelay $ 1000000 * 30
void $ tryIO $ removeFile fp void $ tryIO $ removeFile (fromString fp)
return oldKill return oldKill
update update
@ -125,11 +125,11 @@ hoogleUrl n = concat
getHoogleDB :: Bool -- ^ print exceptions? getHoogleDB :: Bool -- ^ print exceptions?
-> Manager -> SnapName -> IO (Maybe FilePath) -> Manager -> SnapName -> IO (Maybe FilePath)
getHoogleDB toPrint man name = do getHoogleDB toPrint man name = do
let fp = fpFromText $ hoogleKey name let fp = fromText $ hoogleKey name
fptmp = fp <.> "tmp" fptmp = encodeString fp <.> "tmp"
exists <- isFile fp exists <- isFile fp
if exists if exists
then return $ Just fp then return $ Just (encodeString fp)
else do else do
req' <- parseUrl $ unpack $ hoogleUrl name req' <- parseUrl $ unpack $ hoogleUrl name
let req = req' let req = req'
@ -138,12 +138,12 @@ getHoogleDB toPrint man name = do
} }
withResponse req man $ \res -> if responseStatus res == status200 withResponse req man $ \res -> if responseStatus res == status200
then do then do
createTree $ parent fptmp createTree $ parent (fromString fptmp)
runResourceT $ bodyReaderSource (responseBody res) runResourceT $ bodyReaderSource (responseBody res)
$= ungzip $= ungzip
$$ sinkFile fptmp $$ sinkFile fptmp
rename fptmp fp rename (fromString fptmp) fp
return $ Just fp return $ Just $ encodeString fp
else do else do
when toPrint $ mapM brRead res >>= print when toPrint $ mapM brRead res >>= print
return Nothing return Nothing
@ -157,7 +157,7 @@ stackageServerCron = do
env <- getEnv NorthVirginia Discover env <- getEnv NorthVirginia Discover
let upload :: FilePath -> Text -> IO () let upload :: FilePath -> Text -> IO ()
upload fp key = do upload fp key = do
let fpgz = fpToString $ fp <.> "gz" let fpgz = fp <.> "gz"
runResourceT $ sourceFile fp runResourceT $ sourceFile fp
$$ compress 9 (WindowBits 31) $$ compress 9 (WindowBits 31)
=$ CB.sinkFile fpgz =$ CB.sinkFile fpgz
@ -171,9 +171,9 @@ stackageServerCron = do
Left e -> error $ show (fp, key, e) Left e -> error $ show (fp, key, e)
Right _ -> putStrLn "Success" Right _ -> putStrLn "Success"
let dbfp = fpFromText keyName let dbfp = fromText keyName
createStackageDatabase dbfp createStackageDatabase dbfp
upload dbfp keyName upload (encodeString dbfp) keyName
db <- openStackageDatabase dbfp db <- openStackageDatabase dbfp
@ -200,33 +200,33 @@ stackageServerCron = do
forM_ mfp' $ \fp -> do forM_ mfp' $ \fp -> do
let key = hoogleKey name let key = hoogleKey name
upload fp key upload fp key
let dest = fpFromText key let dest = unpack key
createTree $ parent dest createTree $ parent (fromString dest)
rename fp dest rename (fromString fp) (fromString dest)
createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath) createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath)
createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
req' <- parseUrl $ unpack tarUrl req' <- parseUrl $ unpack tarUrl
let req = req' { decompress = const True } 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" let tmp = tarFP <.> "tmp"
createTree $ parent tmp createTree $ parent (fromString tmp)
runResourceT $ bodyReaderSource (responseBody res) runResourceT $ bodyReaderSource (responseBody res)
$$ sinkFile tmp $$ sinkFile tmp
rename tmp tarFP rename (fromString tmp) (fromString tarFP)
void $ tryIO $ removeTree bindir void $ tryIO $ removeTree (fromString bindir)
void $ tryIO $ removeFile outname void $ tryIO $ removeFile (fromString outname)
createTree bindir createTree (fromString bindir)
dbs <- runResourceT dbs <- runResourceT
$ sourceTarFile False (fpToString tarFP) $ sourceTarFile False tarFP
$$ evalStateC 1 (mapMC (singleDB db name bindir)) $$ evalStateC 1 (mapMC (singleDB db name bindir))
=$ sinkList =$ sinkList
putStrLn "Merging databases..." putStrLn "Merging databases..."
Hoogle.mergeDatabase (map fpToString $ catMaybes dbs) (fpToString outname) Hoogle.mergeDatabase (catMaybes dbs) outname
putStrLn "Merge done" putStrLn "Merge done"
return $ Just outname return $ Just outname
@ -237,7 +237,7 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
tarKey = toPathPiece name ++ "/hoogle/orig.tar" tarKey = toPathPiece name ++ "/hoogle/orig.tar"
tarUrl = "https://s3.amazonaws.com/haddock.stackage.org/" ++ tarKey tarUrl = "https://s3.amazonaws.com/haddock.stackage.org/" ++ tarKey
tarFP = root </> fpFromText tarKey tarFP = root </> unpack tarKey
singleDB :: StackageDatabase singleDB :: StackageDatabase
-> SnapName -> SnapName
@ -260,7 +260,7 @@ singleDB db sname bindir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
Just (Entity _ sp) -> do Just (Entity _ sp) -> do
let ver = snapshotPackageVersion sp let ver = snapshotPackageVersion sp
pkgver = concat [pkg, "-", ver] pkgver = concat [pkg, "-", ver]
out = bindir </> fpFromString (show idx) <.> "hoo" out = bindir </> show idx <.> "hoo"
src' = unlines src' = unlines
$ haddockHacks (Just $ unpack docsUrl) $ haddockHacks (Just $ unpack docsUrl)
$ lines $ lines
@ -274,7 +274,7 @@ singleDB db sname bindir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do
, "/index.html" , "/index.html"
] ]
_errs <- liftIO $ Hoogle.createDatabase "" Hoogle.Haskell [] src' $ fpToString out _errs <- liftIO $ Hoogle.createDatabase "" Hoogle.Haskell [] src' out
return $ Just out return $ Just out
singleDB _ _ _ _ = return Nothing singleDB _ _ _ _ = return Nothing

4
Stackage/Database/Haddock.hs
View File

@ -5,12 +5,12 @@ module Stackage.Database.Haddock
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A import qualified Text.Blaze.Html5.Attributes as A
import qualified Documentation.Haddock.Parser as Haddock 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 ClassyPrelude.Conduit
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
renderHaddock :: Text -> Html renderHaddock :: Text -> Html
renderHaddock = hToHtml . Haddock.toRegular . Haddock.parseParas . unpack renderHaddock = hToHtml . Haddock.toRegular . _doc . Haddock.parseParas . unpack
-- | Convert a Haddock doc to HTML. -- | Convert a Haddock doc to HTML.
hToHtml :: DocH String String -> Html hToHtml :: DocH String String -> Html

1065
cabal.config
View File

File diff suppressed because it is too large Load Diff

5
stack.yaml
View File

@ -1,5 +1,4 @@
packages: packages:
- . - .
extra-deps: extra-deps: []
- stackage-metadata-0.3.0.0 resolver: lts-3.2
resolver: lts-2.17

10
stackage-server.cabal
View File

@ -93,7 +93,7 @@ library
, blaze-markup >= 0.6 , blaze-markup >= 0.6
, byteable , byteable
, bytestring >= 0.9 , bytestring >= 0.9
, classy-prelude-yesod >= 0.9.2 && < 0.12 , classy-prelude-yesod >= 0.9.2
, conduit >= 1.0 , conduit >= 1.0
, conduit-extra , conduit-extra
, cryptohash , cryptohash
@ -127,13 +127,13 @@ library
, wai-extra >= 2.1 , wai-extra >= 2.1
, wai-logger >= 2.1 , wai-logger >= 2.1
, warp >= 2.1 , warp >= 2.1
, xml-conduit < 1.3 , xml-conduit
, yaml >= 0.8 , yaml >= 0.8
, yesod >= 1.2.5 , yesod >= 1.2.5
, yesod-auth >= 1.3 , yesod-auth >= 1.3
, yesod-core >= 1.2.19 , yesod-core >= 1.2.19
, yesod-form >= 1.3.14 , yesod-form >= 1.3.14
, yesod-static >= 1.2 && < 1.5 , yesod-static >= 1.2
, zlib , zlib
, unordered-containers , unordered-containers
, hashable , hashable
@ -150,9 +150,9 @@ library
, markdown >= 0.1.13 , markdown >= 0.1.13
, formatting , formatting
, blaze-html , blaze-html
, haddock-library , haddock-library >= 1.2.0
, async , async
, yesod-gitrepo >= 0.1.1 && < 0.2 , yesod-gitrepo >= 0.1.1
, hoogle , hoogle
, spoon , spoon
, deepseq , deepseq