Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Threadsafe logging #11

Merged
merged 1 commit into from
Apr 12, 2019
Merged

Threadsafe logging #11

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions hw-ci-assist.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -95,6 +95,7 @@ library
HaskellWorks.Ci.Assist.Tar
HaskellWorks.Ci.Assist.Text
HaskellWorks.Ci.Assist.Types
HaskellWorks.Ci.Assist.IO.Console

hs-source-dirs: src

Expand Down
55 changes: 31 additions & 24 deletions src/App/Commands/SyncFromArchive.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,21 +22,23 @@ import HaskellWorks.Ci.Assist.PackageConfig (unTemplateConfig)
import HaskellWorks.Ci.Assist.Tar (mapEntriesWith)
import Options.Applicative hiding (columns)

import qualified App.Commands.Options.Types as Z
import qualified Codec.Archive.Tar as F
import qualified Codec.Compression.GZip as F
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified HaskellWorks.Ci.Assist.IO.Lazy as IO
import qualified HaskellWorks.Ci.Assist.Types as Z
import qualified System.Directory as IO
import qualified System.Exit as IO
import qualified System.IO as IO
import qualified System.Process as IO
import qualified UnliftIO.Async as IO
import qualified App.Commands.Options.Types as Z
import qualified Codec.Archive.Tar as F
import qualified Codec.Compression.GZip as F
import qualified Control.Monad.Trans.AWS as AWS
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified HaskellWorks.Ci.Assist.IO.Console as CIO
import qualified HaskellWorks.Ci.Assist.IO.Lazy as IO
import qualified HaskellWorks.Ci.Assist.Types as Z
import qualified System.Directory as IO
import qualified System.Exit as IO
import qualified System.IO as IO
import qualified System.Process as IO
import qualified UnliftIO.Async as IO

{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
Expand All @@ -47,29 +49,29 @@ logger _ _ = return ()
runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO ()
runSyncFromArchive opts = do
let archiveUri = opts ^. the @"archiveUri"
T.putStrLn $ "Archive URI: " <> archiveUri
CIO.putStrLn $ "Archive URI: " <> archiveUri

hGhcPkg <- IO.spawnProcess "ghc-pkg" ["--version"]

exitCodeGhcPkg <- IO.waitForProcess hGhcPkg

case exitCodeGhcPkg of
IO.ExitFailure _ -> do
IO.hPutStrLn IO.stderr "ERROR: Unable to get ghc-pkg verson"
CIO.hPutStrLn IO.stderr "ERROR: Unable to get ghc-pkg verson"
IO.exitWith (IO.ExitFailure 1)
_ -> return ()

lbs <- LBS.readFile "dist-newstyle/cache/plan.json"
case A.eitherDecode lbs of
Right (planJson :: Z.PlanJson) -> do
env <- mkEnv Oregon logger
env <- mkEnv Sydney logger
let archivePath = archiveUri <> "/" <> (planJson ^. the @"compilerId")
let baseDir = opts ^. the @"storePath"
let storeCompilerPath = baseDir <> "/" <> (planJson ^. the @"compilerId")
let storeCompilerPackageDbPath = storeCompilerPath <> "/package.db"
let storeCompilerLibPath = storeCompilerPath <> "/lib"

IO.putStrLn "Creating store directories"
CIO.putStrLn "Creating store directories"
IO.createDirectoryIfMissing True (T.unpack baseDir)
IO.createDirectoryIfMissing True (T.unpack storeCompilerPath)
IO.createDirectoryIfMissing True (T.unpack storeCompilerLibPath)
Expand All @@ -86,26 +88,26 @@ runSyncFromArchive opts = do
maybeArchiveFileContents <- IO.readResource env archiveFile
case maybeArchiveFileContents of
Just archiveFileContents -> do
liftIO $ T.putStrLn $ "Extracting " <> archiveFile
liftIO $ CIO.putStrLn $ "Extracting " <> archiveFile
let entries = F.read (F.decompress archiveFileContents)
let entries' = case confPath pInfo of
Nothing -> entries
Just conf -> mapEntriesWith (== T.unpack conf) (unTemplateConfig (T.unpack baseDir)) entries

liftIO $ F.unpack (T.unpack baseDir) entries'
Nothing -> do
liftIO $ T.putStrLn $ "Archive unavilable: " <> archiveFile
IO.putStrLn "Recaching package database"
liftIO $ CIO.putStrLn $ "Archive unavilable: " <> archiveFile
CIO.putStrLn "Recaching package database"
hGhcPkg2 <- IO.spawnProcess "ghc-pkg" ["recache", "--package-db", T.unpack storeCompilerPackageDbPath]
exitCodeGhcPkg2 <- IO.waitForProcess hGhcPkg2
case exitCodeGhcPkg2 of
IO.ExitFailure _ -> do
IO.hPutStrLn IO.stderr "ERROR: Unable to recache package db"
CIO.hPutStrLn IO.stderr "ERROR: Unable to recache package db"
IO.exitWith (IO.ExitFailure 1)
_ -> return ()

Left errorMessage -> do
IO.putStrLn $ "ERROR: Unable to parse plan.json file: " <> errorMessage
CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage

return ()

Expand All @@ -132,3 +134,8 @@ optsSyncFromArchive = Z.SyncFromArchiveOptions

cmdSyncFromArchive :: Mod CommandFields (IO ())
cmdSyncFromArchive = command "sync-from-archive" $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

modifyEndpoint :: AWS.Service -> AWS.Service
modifyEndpoint s = if s ^. to AWS._svcAbbrev == "s3"
then AWS.setEndpoint True "s3.ap-southeast-2.amazonaws.com" 443 s
else s
35 changes: 21 additions & 14 deletions src/App/Commands/SyncToArchive.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,17 +24,19 @@ import qualified App.Commands.Options.Types as Z
import qualified Codec.Archive.Tar as F
import qualified Codec.Archive.Tar.Entry as F

import qualified Codec.Compression.GZip as F
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified HaskellWorks.Ci.Assist.IO.Lazy as IO
import qualified HaskellWorks.Ci.Assist.Types as Z
import qualified System.Directory as IO
import qualified System.IO as IO
import qualified UnliftIO.Async as IO
import qualified Codec.Compression.GZip as F
import qualified Control.Monad.Trans.AWS as AWS
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified HaskellWorks.Ci.Assist.IO.Console as CIO
import qualified HaskellWorks.Ci.Assist.IO.Lazy as IO
import qualified HaskellWorks.Ci.Assist.Types as Z
import qualified System.Directory as IO
import qualified System.IO as IO
import qualified UnliftIO.Async as IO

{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
Expand All @@ -48,7 +50,7 @@ runSyncToArchive opts = do
lbs <- LBS.readFile "dist-newstyle/cache/plan.json"
case A.eitherDecode lbs of
Right (planJson :: Z.PlanJson) -> do
envAws <- mkEnv Oregon logger
envAws <- mkEnv Sydney logger
let archivePath = homeDirectory <> "/.cabal/archive/" <> (planJson ^. the @"compilerId")
IO.createDirectoryIfMissing True (T.unpack archivePath)
let baseDir = opts ^. the @"storePath"
Expand All @@ -60,7 +62,7 @@ runSyncToArchive opts = do
packageStorePathExists <- IO.doesDirectoryExist (T.unpack packageStorePath)
archiveFileExists <- runResourceT $ IO.resourceExists envAws archiveFile
when (not archiveFileExists && packageStorePathExists) $ do
T.putStrLn $ "Creating " <> archiveFile
CIO.putStrLn $ "Creating " <> archiveFile
entries <- F.pack (T.unpack baseDir) (relativePaths pInfo)

let entries' = case confPath pInfo of
Expand All @@ -70,7 +72,7 @@ runSyncToArchive opts = do
IO.writeResource envAws archiveFile . F.compress . F.write $ entries

Left errorMessage -> do
IO.putStrLn $ "ERROR: Unable to parse plan.json file: " <> errorMessage
CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage

return ()

Expand All @@ -97,3 +99,8 @@ optsSyncToArchive = Z.SyncToArchiveOptions

cmdSyncToArchive :: Mod CommandFields (IO ())
cmdSyncToArchive = command "sync-to-archive" $ flip info idm $ runSyncToArchive <$> optsSyncToArchive

modifyEndpoint :: AWS.Service -> AWS.Service
modifyEndpoint s = if s ^. to AWS._svcAbbrev == "s3"
then AWS.setEndpoint True "s3.ap-southeast-2.amazonaws.com" 443 s
else s
35 changes: 35 additions & 0 deletions src/HaskellWorks/Ci/Assist/IO/Console.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,35 @@
module HaskellWorks.Ci.Assist.IO.Console
( putStrLn
, print
, hPutStrLn
, hPrint
) where

import Control.Exception (bracket_)
import Data.Text (Text)
import Prelude (IO, Show (..), ($))

import qualified Control.Concurrent.QSem as IO
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified System.IO as IO
import qualified System.IO.Unsafe as IO

sem :: IO.QSem
sem = IO.unsafePerformIO $ IO.newQSem 1
{-# NOINLINE sem #-}

consoleBracket :: IO a -> IO a
consoleBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)

putStrLn :: Text -> IO ()
putStrLn text = consoleBracket $ T.putStrLn text

print :: Show a => a -> IO ()
print a = consoleBracket $ IO.print a

hPutStrLn :: IO.Handle -> Text -> IO ()
hPutStrLn h text = consoleBracket $ T.hPutStrLn h text

hPrint :: Show a => IO.Handle -> a -> IO ()
hPrint h a = consoleBracket $ IO.hPrint h a