mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
Remove system-file(path/io)
This commit is contained in:
Michael Snoyman
parent
014114855b
commit
96e9a53a17
@ -39,8 +39,6 @@ dependencies:
|
||||
- persistent-template
|
||||
- resourcet
|
||||
- shakespeare
|
||||
- system-fileio
|
||||
- system-filepath
|
||||
- tar
|
||||
- template-haskell
|
||||
- temporary
|
||||
|
||||
@ -7,7 +7,7 @@ import ClassyPrelude.Yesod
|
||||
import Control.Monad.State.Strict (modify, execStateT)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.Yaml as Yaml
|
||||
import Filesystem (readTextFile, isFile)
|
||||
import System.Directory
|
||||
|
||||
import Types
|
||||
|
||||
@ -37,7 +37,7 @@ readGhcLinks dir = do
|
||||
path = dir
|
||||
</> unpack (toPathPiece arch)
|
||||
</> unpack fileName
|
||||
whenM (liftIO $ isFile (fromString path)) $ do
|
||||
text <- liftIO $ readTextFile (fromString path)
|
||||
whenM (liftIO $ doesFileExist path) $ do
|
||||
text <- liftIO $ readFileUtf8 path
|
||||
modify (HashMap.insert (arch, ver) text)
|
||||
return $ GhcLinks hashMap
|
||||
|
||||
@ -53,13 +53,12 @@ import CMarkGFM
|
||||
import System.Directory (removeFile)
|
||||
import Stackage.Database.Haddock
|
||||
import System.FilePath (takeBaseName, takeExtension)
|
||||
import ClassyPrelude.Conduit hiding (pi, FilePath, (</>))
|
||||
import ClassyPrelude.Conduit hiding (pi)
|
||||
import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
|
||||
import Yesod.Form.Fields (Textarea (..))
|
||||
import Stackage.Database.Types
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import qualified Filesystem as F
|
||||
import Filesystem.Path.CurrentOS (filename, directory, FilePath, encodeString, (</>))
|
||||
import System.Directory (getAppUserDataDirectory, doesDirectoryExist, createDirectoryIfMissing)
|
||||
import System.FilePath (takeFileName, takeDirectory)
|
||||
import Data.Conduit.Process
|
||||
import Stackage.Types
|
||||
import Stackage.Metadata
|
||||
@ -182,23 +181,23 @@ sourceBuildPlans :: MonadResource m => FilePath -> ConduitT i (SnapName, FilePat
|
||||
sourceBuildPlans root = do
|
||||
forM_ ["lts-haskell", "stackage-nightly"] $ \repoName -> do
|
||||
dir <- liftIO $ cloneOrUpdate root "fpco" repoName
|
||||
sourceDirectory (encodeString dir) .| concatMapMC (go Left . fromString)
|
||||
sourceDirectory dir .| concatMapMC (go Left . fromString)
|
||||
let docdir = dir </> "docs"
|
||||
whenM (liftIO $ F.isDirectory docdir) $
|
||||
sourceDirectory (encodeString docdir) .| concatMapMC (go Right . fromString)
|
||||
whenM (liftIO $ doesDirectoryExist docdir) $
|
||||
sourceDirectory docdir .| concatMapMC (go Right . fromString)
|
||||
where
|
||||
go wrapper fp | Just name <- nameFromFP fp = liftIO $ do
|
||||
let bp = decodeFileEither (encodeString fp) >>= either throwIO return
|
||||
let bp = decodeFileEither fp >>= either throwIO return
|
||||
return $ Just (name, fp, wrapper bp)
|
||||
go _ _ = return Nothing
|
||||
|
||||
nameFromFP fp = do
|
||||
base <- stripSuffix ".yaml" $ pack $ encodeString $ filename fp
|
||||
base <- stripSuffix ".yaml" $ pack $ takeFileName fp
|
||||
fromPathPiece base
|
||||
|
||||
cloneOrUpdate :: FilePath -> String -> String -> IO FilePath
|
||||
cloneOrUpdate root org name = do
|
||||
exists <- F.isDirectory dest
|
||||
exists <- doesDirectoryExist dest
|
||||
if exists
|
||||
then do
|
||||
let git = runIn dest "git"
|
||||
@ -214,7 +213,7 @@ runIn :: FilePath -> String -> [String] -> IO ()
|
||||
runIn dir cmd args =
|
||||
withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
|
||||
where
|
||||
cp = (proc cmd args) { cwd = Just $ encodeString dir }
|
||||
cp = (proc cmd args) { cwd = Just dir }
|
||||
|
||||
openStackageDatabase :: MonadIO m => PostgresConf -> m StackageDatabase
|
||||
openStackageDatabase pg = liftIO $ do
|
||||
@ -244,8 +243,8 @@ createStackageDatabase fp = liftIO $ do
|
||||
runMigration migrateAll
|
||||
unless schemaMatch $ insert_ $ Schema currentSchema
|
||||
|
||||
root <- liftIO $ fmap (</> fromString "database") $ fmap fromString $ getAppUserDataDirectory "stackage"
|
||||
F.createTree root
|
||||
root <- liftIO $ (</> "database") <$> getAppUserDataDirectory "stackage"
|
||||
createDirectoryIfMissing True root
|
||||
runResourceT $ do
|
||||
putStrLn "Updating all-cabal-metadata repo"
|
||||
flip runSqlPool pool $ runConduit $ sourcePackages root .| getZipSink
|
||||
@ -369,9 +368,9 @@ addPlan name fp bp = do
|
||||
[ "log"
|
||||
, "--format=%ad"
|
||||
, "--date=short"
|
||||
, encodeString $ filename fp
|
||||
, takeFileName fp
|
||||
]
|
||||
cp = cp' { cwd = Just $ encodeString $ directory fp }
|
||||
cp = cp' { cwd = Just $ takeDirectory fp }
|
||||
t <- withCheckedProcess cp $ \ClosedStream out ClosedStream ->
|
||||
runConduit $ out .| decodeUtf8C .| foldC
|
||||
case readMay $ concat $ take 1 $ words t of
|
||||
|
||||
@ -11,9 +11,8 @@ import qualified Codec.Archive.Tar as Tar
|
||||
import Stackage.Database
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Client.Conduit (bodyReaderSource)
|
||||
import Filesystem (rename, removeTree, removeFile, isFile, createTree)
|
||||
import System.Directory
|
||||
import Web.PathPieces (toPathPiece)
|
||||
import Filesystem.Path.CurrentOS (parent, fromText, encodeString)
|
||||
import Network.HTTP.Types (status200)
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
import Network.AWS (Credentials (Discover), newEnv,
|
||||
@ -30,10 +29,9 @@ import qualified Data.Conduit.Binary as CB
|
||||
import Data.Conduit.Zlib (WindowBits (WindowBits),
|
||||
compress, ungzip)
|
||||
import qualified Hoogle
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import Control.SingleRun
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import System.FilePath (splitPath)
|
||||
import System.FilePath (splitPath, takeDirectory)
|
||||
import System.Environment (getEnv)
|
||||
|
||||
hoogleKey :: SnapName -> Text
|
||||
@ -55,24 +53,24 @@ newHoogleLocker :: Bool -- ^ print exceptions?
|
||||
-> Manager
|
||||
-> IO (SingleRun SnapName (Maybe FilePath))
|
||||
newHoogleLocker toPrint man = mkSingleRun $ \name -> do
|
||||
let fp = fromText $ hoogleKey name
|
||||
fptmp = encodeString fp <.> "tmp"
|
||||
let fp = unpack $ hoogleKey name
|
||||
fptmp = fp <.> "tmp"
|
||||
|
||||
exists <- isFile fp
|
||||
exists <- doesFileExist fp
|
||||
if exists
|
||||
then return $ Just (encodeString fp)
|
||||
then return $ Just fp
|
||||
else do
|
||||
req' <- parseRequest $ unpack $ hoogleUrl name
|
||||
let req = req' { decompress = const False }
|
||||
withResponse req man $ \res -> if responseStatus res == status200
|
||||
then do
|
||||
createTree $ parent (fromString fptmp)
|
||||
createDirectoryIfMissing True $ takeDirectory fptmp
|
||||
runConduitRes
|
||||
$ bodyReaderSource (responseBody res)
|
||||
.| ungzip
|
||||
.| sinkFile fptmp
|
||||
rename (fromString fptmp) fp
|
||||
return $ Just $ encodeString fp
|
||||
renamePath fptmp fp
|
||||
return $ Just fp
|
||||
else do
|
||||
when toPrint $ mapM brRead res >>= print
|
||||
return Nothing
|
||||
@ -139,8 +137,8 @@ stackageServerCron = do
|
||||
let key = hoogleKey name
|
||||
upload fp (ObjectKey key)
|
||||
let dest = unpack key
|
||||
createTree $ parent (fromString dest)
|
||||
rename (fromString fp) (fromString dest)
|
||||
createDirectoryIfMissing True $ takeDirectory dest
|
||||
renamePath fp dest
|
||||
|
||||
createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath)
|
||||
createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
|
||||
@ -148,17 +146,17 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
|
||||
req' <- parseRequest $ unpack tarUrl
|
||||
let req = req' { decompress = const True }
|
||||
|
||||
unlessM (isFile (fromString tarFP)) $ withResponse req man $ \res -> do
|
||||
unlessM (doesFileExist tarFP) $ withResponse req man $ \res -> do
|
||||
let tmp = tarFP <.> "tmp"
|
||||
createTree $ parent (fromString tmp)
|
||||
createDirectoryIfMissing True $ takeDirectory tmp
|
||||
runConduitRes
|
||||
$ bodyReaderSource (responseBody res)
|
||||
.| sinkFile tmp
|
||||
rename (fromString tmp) (fromString tarFP)
|
||||
renamePath tmp tarFP
|
||||
|
||||
void $ tryIO $ removeTree (fromString bindir)
|
||||
void $ tryIO $ removeFile (fromString outname)
|
||||
createTree (fromString bindir)
|
||||
void $ tryIO $ removeDirectoryRecursive bindir
|
||||
void $ tryIO $ removeFile outname
|
||||
createDirectoryIfMissing True bindir
|
||||
|
||||
withSystemTempDirectory ("hoogle-" ++ unpack (toPathPiece name)) $ \tmpdir -> do
|
||||
allPackagePairs <- runConduitRes
|
||||
|
||||
Loading…
Reference in New Issue
Block a user