diff --git a/Data/GhcLinks.hs b/Data/GhcLinks.hs index c54873e..9a8fb49 100644 --- a/Data/GhcLinks.hs +++ b/Data/GhcLinks.hs @@ -37,7 +37,7 @@ readGhcLinks dir = do path = dir fpFromText (toPathPiece arch) fpFromText fileName - whenM (liftIO $ isFile path) $ do - text <- liftIO $ readTextFile path + whenM (liftIO $ isFile (fromString path)) $ do + text <- liftIO $ readTextFile (fromString path) modify (HashMap.insert (arch, ver) text) return $ GhcLinks hashMap diff --git a/Stackage/Database.hs b/Stackage/Database.hs index c2832d7..5604dff 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -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 diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 50e148a..cef7c40 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -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) @@ -81,14 +81,14 @@ loadFromS3 man = do let update = do fp <- download - db <- openStackageDatabase fp + db <- openStackageDatabase (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 @@ -113,11 +113,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' @@ -126,12 +126,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 @@ -159,9 +159,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 @@ -189,24 +189,24 @@ stackageServerCron = do let key = hoogleKey name upload fp key let dest = fpFromText key - createTree $ parent dest - rename fp dest + 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)