Quickfix filesystem related stuff by coercing it around

Data/GhcLinks.hs

@@ -37,7 +37,7 @@ readGhcLinks dir = do
             path = dir
               </> fpFromText (toPathPiece arch)
               </> fpFromText 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)
       return $ GhcLinks hashMap

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
+        putStrLn $ "Deleting " ++ pack (encodeString fp)
-        void $ tryIO $ removeFile $ fpToString 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

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
+    let fp = fromText $ hoogleKey name
-        fptmp = fp <.> "tmp"
+        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
+                    rename (fromString fptmp) fp
-                    return $ Just 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
+                    createTree $ parent (fromString dest)
-                    rename fp 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 $ removeTree (fromString bindir)
-    void $ tryIO $ removeFile outname
+    void $ tryIO $ removeFile (fromString outname)
-    createTree bindir
+    createTree (fromString bindir)
 
     dbs <- runResourceT
         $ sourceTarFile False (fpToString tarFP)