Do not use deprecated FilePath related functions

This commit is contained in:
Konstantin Zudov 2015-10-06 04:40:37 +03:00
parent 2f96607735
commit 0f74359d79
4 changed files with 17 additions and 17 deletions

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,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)

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)

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

View File

@ -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