mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-24 09:51:57 +01:00
Do not use deprecated FilePath related functions
This commit is contained in:
parent
2f96607735
commit
0f74359d79
@ -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,8 +35,8 @@ 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 (fromString path)) $ do
|
whenM (liftIO $ isFile (fromString path)) $ do
|
||||||
text <- liftIO $ readTextFile (fromString path)
|
text <- liftIO $ readTextFile (fromString path)
|
||||||
modify (HashMap.insert (arch, ver) text)
|
modify (HashMap.insert (arch, ver) text)
|
||||||
|
|||||||
@ -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)
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -66,8 +66,8 @@ loadFromS3 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)
|
||||||
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)
|
||||||
@ -145,7 +145,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
|
||||||
@ -188,7 +188,7 @@ 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 (fromString dest)
|
createTree $ parent (fromString dest)
|
||||||
rename (fromString fp) (fromString dest)
|
rename (fromString fp) (fromString dest)
|
||||||
|
|
||||||
@ -209,12 +209,12 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do
|
|||||||
createTree (fromString 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
|
||||||
@ -225,7 +225,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
|
||||||
@ -248,7 +248,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
|
||||||
@ -262,7 +262,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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user