Plugins

.hlint.yaml

@@ -10,6 +10,7 @@
 - ignore: {name: "Unused LANGUAGE pragma"}
 - ignore: {name: "Move brackets to avoid $"}
 - ignore: {name: "Monoid law, left identity"}
+- ignore: {name: "Use let"}
 
 
 # Specify additional command line arguments

app/App/Commands/SyncFromArchive.hs

@@ -41,16 +41,20 @@ import qualified Data.List                                        as L
 import qualified Data.Map                                         as M
 import qualified Data.Map.Strict                                  as Map
 import qualified Data.Text                                        as T
+import qualified Data.Text.Encoding                               as T
+import qualified Data.Yaml                                        as Y
 import qualified HaskellWorks.CabalCache.AWS.Env                  as AWS
 import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ
 import qualified HaskellWorks.CabalCache.Concurrent.Fork          as IO
+import qualified HaskellWorks.CabalCache.Config                   as CONFIG
 import qualified HaskellWorks.CabalCache.Core                     as Z
 import qualified HaskellWorks.CabalCache.Data.List                as L
 import qualified HaskellWorks.CabalCache.GhcPkg                   as GhcPkg
 import qualified HaskellWorks.CabalCache.Hash                     as H
 import qualified HaskellWorks.CabalCache.IO.Console               as CIO
 import qualified HaskellWorks.CabalCache.IO.Lazy                  as IO
 import qualified HaskellWorks.CabalCache.IO.Tar                   as IO
+import qualified HaskellWorks.CabalCache.Text                     as T
 import qualified HaskellWorks.CabalCache.Types                    as Z
 import qualified System.Directory                                 as IO
 import qualified System.IO                                        as IO
@@ -75,6 +79,11 @@ runSyncFromArchive opts = do
   let storePathHash         = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)
   let scopedArchiveUris     = versionedArchiveUris & each %~ (</> T.pack storePathHash)
 
+  cabalCacheConfig <- CONFIG.loadConfigFile CONFIG.defaultConfigFile
+
+  CIO.putStrLn "Using config:"
+  CIO.putStrLn $ T.indentLines $ T.decodeUtf8 (Y.encode cabalCacheConfig)
+
   CIO.putStrLn $ "Store path: "       <> toText storePath
   CIO.putStrLn $ "Store path hash: "  <> T.pack storePathHash
   forM_ archiveUris $ \archiveUri -> do

cabal-cache.cabal

@@ -52,6 +52,8 @@ common relation                       { build-depends: relation
 common resourcet                      { build-depends: resourcet                      >= 1.2.2      && < 1.3    }
 common selective                      { build-depends: selective                      >= 0.1.0      && < 0.5    }
 common stm                            { build-depends: stm                            >= 2.5.0.0    && < 3      }
+common streaming                      { build-depends: streaming                      >= 0.2.3.0    && < 0.3    }
+common streaming-bytestring           { build-depends: streaming-bytestring           >= 0.2.0      && < 0.3    }
 common stringsearch                   { build-depends: stringsearch                   >= 0.3.6.6    && < 0.4    }
 common tar                            { build-depends: tar                            >= 0.5.1.0    && < 0.6    }
 common temporary                      { build-depends: temporary                      >= 1.3        && < 1.4    }
@@ -60,7 +62,7 @@ common time                           { build-depends: time
 common topograph                      { build-depends: topograph                      >= 1          && < 2      }
 common transformers                   { build-depends: transformers                   >= 0.5.6.2    && < 0.7    }
 common unliftio                       { build-depends: unliftio                       >= 0.2.10     && < 0.3    }
-common zlib                           { build-depends: zlib                           >= 0.6.2      && < 0.7    }
+common yaml                           { build-depends: yaml                           >= 0.11.5.0   && < 0.12   }
 
 common config
   default-language:     Haskell2010
@@ -99,9 +101,12 @@ library
                       , relation
                       , resourcet
                       , stm
+                      , streaming
+                      , streaming-bytestring
                       , text
                       , topograph
                       , transformers
+                      , yaml
   other-modules:        Paths_cabal_cache
   autogen-modules:      Paths_cabal_cache
   hs-source-dirs:       src
@@ -110,6 +115,8 @@ library
                         HaskellWorks.CabalCache.Concurrent.DownloadQueue
                         HaskellWorks.CabalCache.Concurrent.Fork
                         HaskellWorks.CabalCache.Concurrent.Type
+                        HaskellWorks.CabalCache.Config
+                        HaskellWorks.CabalCache.Config.Types
                         HaskellWorks.CabalCache.Core
                         HaskellWorks.CabalCache.Data.List
                         HaskellWorks.CabalCache.Error
@@ -123,6 +130,7 @@ library
                         HaskellWorks.CabalCache.Location
                         HaskellWorks.CabalCache.Metadata
                         HaskellWorks.CabalCache.Options
+                        HaskellWorks.CabalCache.Plugin
                         HaskellWorks.CabalCache.Show
                         HaskellWorks.CabalCache.Text
                         HaskellWorks.CabalCache.Topology
@@ -151,6 +159,7 @@ executable cabal-cache
                       , temporary
                       , text
                       , unliftio
+                      , yaml
   build-depends:        cabal-cache
   main-is:              Main.hs
   hs-source-dirs:       app

src/HaskellWorks/CabalCache/Config.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module HaskellWorks.CabalCache.Config
+  ( CabalCacheConfig
+  , Plugin
+
+  , defaultConfigFile
+  , loadConfigFile
+  ) where
+
+import HaskellWorks.CabalCache.Config.Types (CabalCacheConfig, Plugin, defaultConfig)
+import System.FilePath                      ((</>))
+
+import qualified Data.Yaml        as Y
+import qualified System.Directory as IO
+import qualified System.Exit      as IO
+import qualified System.IO        as IO
+import qualified System.IO.Unsafe as IO
+
+defaultConfigFile :: FilePath
+defaultConfigFile = IO.unsafePerformIO $ do
+  home <- IO.getHomeDirectory
+  return $ home </> ".cabal-cache.yaml"
+{-# NOINLINE defaultConfigFile #-}
+
+loadConfigFile :: FilePath -> IO CabalCacheConfig
+loadConfigFile configFile = do
+  exists <- IO.doesFileExist configFile
+
+  if exists
+    then do
+      result <- Y.decodeFileEither configFile
+      case result of
+        Right config -> return config
+        Left exception -> do
+          IO.hPutStrLn IO.stderr $ "Config file error: " <> show exception
+          IO.exitFailure
+    else return defaultConfig

src/HaskellWorks/CabalCache/Config/Types.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE InstanceSigs      #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+
+module HaskellWorks.CabalCache.Config.Types
+  ( CabalCacheConfig(..)
+  , Plugin(..)
+
+  , defaultConfig
+  ) where
+
+import Control.Lens              hiding ((.=))
+import Data.Aeson                (FromJSON (..), ToJSON, Value, (.:), (.=))
+import Data.Aeson.Types          (Parser)
+import Data.Generics.Product.Any
+import Data.Text                 (Text)
+import GHC.Generics              (Generic (..))
+import Network.URI               (URI)
+
+import qualified Data.Aeson       as J
+import qualified Data.Aeson.Types as J
+import qualified Network.URI      as URI
+
+newtype CabalCacheConfig = CabalCacheConfig
+  { plugins :: [Plugin]
+  } deriving (Eq, Show, Generic)
+
+data Plugin = Plugin
+  { name      :: Text
+  , binary    :: FilePath
+  , uriPrefix :: URI
+  } deriving (Eq, Show, Generic)
+
+defaultConfig :: CabalCacheConfig
+defaultConfig = CabalCacheConfig
+  { plugins = []
+  }
+
+instance FromJSON CabalCacheConfig where
+  parseJSON = J.withObject "CabalCacheConfig" $ \v -> CabalCacheConfig
+    <$> v .: "plugins"
+
+instance ToJSON CabalCacheConfig where
+  toJSON config = J.object
+    [ "plugins" .= J.toJSON (config ^. the @"plugins")
+    ]
+
+instance FromJSON Plugin where
+  parseJSON = J.withObject "Plugin" $ \v -> Plugin
+    <$> v .: "name"
+    <*> v .: "binary"
+    <*> ((v .: "uriPrefix") >>= parseUri)
+
+instance ToJSON Plugin where
+  toJSON config = J.object
+    [ "name"      .= J.toJSON (config ^. the @"name")
+    , "binary"    .= J.toJSON (config ^. the @"binary")
+    , "uriPrefix" .= J.toJSON (config ^. the @"uriPrefix" & show)
+    ]
+
+parseUri :: Value -> Parser URI
+parseUri v = do
+  s <- parseJSON @String v
+
+  case URI.parseURI s of
+    Just uri -> return uri
+    Nothing  -> J.typeMismatch "URI" v

src/HaskellWorks/CabalCache/Plugin.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module HaskellWorks.CabalCache.Plugin
+  ( pluginProc
+  , nothingAsError
+  , withPluginProcess
+  , pluginPut
+  , pluginGet
+  , pluginHead
+  ) where
+
+import Control.Lens
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Data.Generics.Product.Any
+import HaskellWorks.CabalCache.Config (CabalCacheConfig)
+import HaskellWorks.CabalCache.Error
+import Network.URI                    (URI)
+import System.Exit                    (ExitCode (ExitFailure, ExitSuccess))
+import System.IO                      (Handle)
+import System.Process                 (ProcessHandle)
+
+import qualified Data.ByteString.Lazy                 as LBS
+import qualified Data.List                            as L
+import           HaskellWorks.CabalCache.Config.Types (Plugin)
+import qualified System.Process                       as IO
+
+newtype PluginError = PluginError String deriving (Eq, Show)
+
+pluginProc :: FilePath -> [String] -> IO.CreateProcess
+pluginProc exe args = (IO.proc exe args)
+  { IO.std_in   = IO.CreatePipe
+  , IO.std_out  = IO.CreatePipe
+  , IO.std_err  = IO.CreatePipe
+  }
+
+nothingAsError :: Monad m => e -> Maybe a -> ExceptT e m a
+nothingAsError e = maybe (throwE e) pure
+
+withPluginProcess
+  :: IO.CreateProcess
+  -> (Handle -> Handle -> Handle -> ProcessHandle -> IO a)
+  -> ExceptT PluginError IO a
+withPluginProcess cp f = ExceptT $ do
+  IO.withCreateProcess cp $ \mStdin mStdout mStderr hProcess -> runExceptT $ do
+    stdin   <- mStdin   & nothingAsError (PluginError "Plugin stdin not open")
+    stdout  <- mStdout  & nothingAsError (PluginError "Plugin stdout not open")
+    stderr  <- mStderr  & nothingAsError (PluginError "Plugin stdout not open")
+    liftIO $ f stdin stdout stderr hProcess
+
+lookupPluginExe :: CabalCacheConfig -> URI -> Maybe FilePath
+lookupPluginExe cabalCacheConfig uri = fmap (^. the @"binary") (L.find predicate plugins)
+  where plugins :: [Plugin]
+        plugins = cabalCacheConfig ^. the @"plugins"
+        predicate :: Plugin -> Bool
+        predicate plugin = show (plugin ^. the @"uriPrefix") `L.isPrefixOf` show uri
+
+pluginPut :: CabalCacheConfig -> URI -> String -> LBS.ByteString -> ExceptT PluginError IO ()
+pluginPut cabalCacheConfig uri subKey lbs = do
+  exe <- lookupPluginExe cabalCacheConfig uri & nothingToError (PluginError "")
+
+  let cp = pluginProc exe
+        [ "put"
+        , "--uri"     , show uri
+        , "--sub-key" , subKey
+        ]
+
+  (mStdin, mStdout, mStderr, hProcess) <- liftIO $ IO.createProcess cp
+
+  _       <- mStdin   & nothingToError (PluginError "")
+  stdout  <- mStdout  & nothingToError (PluginError "")
+  _       <- mStderr  & nothingToError (PluginError "")
+
+  liftIO $ LBS.hPut stdout lbs
+
+  exitCode <- liftIO $ IO.waitForProcess hProcess
+
+  case exitCode of
+    ExitSuccess   -> return ()
+    ExitFailure n -> throwE $ PluginError $ "Plugin failed with error code " <> show n <> " during put"
+
+pluginGet :: CabalCacheConfig -> URI -> String -> ExceptT PluginError IO LBS.ByteString
+pluginGet cabalCacheConfig uri subKey = do
+  exe <- lookupPluginExe cabalCacheConfig uri & nothingToError (PluginError "")
+
+  let cp = pluginProc exe
+        [ "get"
+        , "--uri"     , show uri
+        , "--sub-key" , subKey
+        ]
+
+  (mStdin, mStdout, mStderr, hProcess) <- liftIO $ IO.createProcess cp
+
+  _       <- mStdin   & nothingToError (PluginError "")
+  stdout  <- mStdout  & nothingToError (PluginError "")
+  _       <- mStderr  & nothingToError (PluginError "")
+
+  exitCode <- liftIO $ IO.waitForProcess hProcess
+
+  case exitCode of
+    ExitSuccess   -> liftIO $ LBS.hGetContents stdout
+    ExitFailure n -> throwE $ PluginError $ "Plugin failed with error code " <> show n <> " during get"
+
+pluginHead :: CabalCacheConfig -> URI -> String -> ExceptT PluginError IO ()
+pluginHead cabalCacheConfig uri subKey = do
+  exe <- lookupPluginExe cabalCacheConfig uri & nothingToError (PluginError "")
+
+  let cp = pluginProc exe
+        [ "head"
+        , "--uri"     , show uri
+        , "--sub-key" , subKey
+        ]
+
+  (mStdin, mStdout, mStderr, hProcess) <- liftIO $ IO.createProcess cp
+
+  _ <- mStdin   & nothingToError (PluginError "")
+  _ <- mStdout  & nothingToError (PluginError "")
+  _ <- mStderr  & nothingToError (PluginError "")
+
+  exitCode <- liftIO $ IO.waitForProcess hProcess
+
+  case exitCode of
+    ExitSuccess   -> return ()
+    ExitFailure n -> throwE $ PluginError $ "Plugin failed with error code " <> show n <> " during head"

src/HaskellWorks/CabalCache/Text.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module HaskellWorks.CabalCache.Text
   ( maybeStripPrefix
+  ,indentLines
   ) where
 
 import Data.Maybe
@@ -9,3 +12,6 @@ import qualified Data.Text as T
 
 maybeStripPrefix :: Text -> Text -> Text
 maybeStripPrefix prefix text = fromMaybe text (T.stripPrefix prefix text)
+
+indentLines :: Text -> Text
+indentLines = T.unlines . fmap ("  " <>) . T.lines