haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-12 04:08:29 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Quickfix filesystem related stuff by coercing it around

Browse Source
This commit is contained in:
Konstantin Zudov 2015-10-05 08:40:27 +03:00
parent 3a88c8835b
commit 2f96607735
3 changed files with 36 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Data/GhcLinks.hs
View File

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

30
Stackage/Database.hs
View File

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

38
Stackage/Database/Cron.hs
View File

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