diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2018 Shea Levy. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +hnix-store-remote +================= + +Nix worker protocol implementation for interacting with remote Nix store +via `nix-daemon`. + +## API + +[System.Nix.Store.Remote]: ./src/System/Nix/Store/Remote.hs + +## Example + +```haskell + +import Data.HashSet as HS +import System.Nix.Store.Remote + +main = do + runStore $ do + syncWithGC + roots <- findRoots + liftIO $ print roots + + res <- addTextToStore "hnix-store" "test" (HS.fromList []) False + print res +``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashSet as HS +import Data.Maybe +import Control.Monad.Reader +import Text.Pretty.Simple +import Data.Proxy + +import qualified System.Nix.GC as GC +import System.Nix.Path (PathHashAlgo) +import System.Nix.Store.Remote +import System.Nix.Store.Remote.Util +import System.Nix.Hash + +noSuchPath = fromJust $ mkPath "blah" + +main = do + x <- runStore $ do + syncWithGC + + verifyStore False False + + (Just path) <- addTextToStore "hnix-store" "test" (HS.fromList []) False + + -- (Just path2) <- addTextToStore "hnix-store2" "test2" (HS.fromList []) False + path2 <- addToStore "hi-test-file" + "/home/greghale/code/hnix-store/hnix-store-remote/hi" + False (Proxy :: Proxy 'SHA256) (const True) False + + valid <- isValidPathUncached path + valid2 <- isValidPathUncached path2 + + case (valid, valid2) of + (True, True) -> do + info <- queryPathInfoUncached path + info2 <- queryPathInfoUncached path2 + return (path, info, path2, info2) + _ -> error "shouldn't happen" + + pPrint x + case x of + (Left err, log) -> putStrLn err >> print log + (Right (path, pathinfo, path2, pathinfo2), log) -> do + gcres <- runStore $ do + collectGarbage $ GC.Options + { GC.operation = GC.DeleteSpecific + , GC.pathsToDelete = HS.fromList [path] + , GC.ignoreLiveness = False + -- XXX: this breaks stuff - we don't get Last, + -- only a message with limit reached, stopping.. + -- + -- gcDeleteSpecific and options.maxFreed + -- are two distinct branches in + -- nix/src/libstore.gc + -- so maybe this combination is not supported + --, GC.maxFreed = 1000 + , GC.maxFreed = -1 + } + + pPrint gcres + + -- test ExceptT + e <- runStore $ do + isValidPathUncached $ noSuchPath + + pPrint e + + {- + e <- runStore $ do + queryPathInfoUncached $ noSuchPath + + pPrint e + -} + + --res <- queryDerivationOutputs drvP + --liftIO $ print res + --res <- findRoots + --liftIO $ pPrint res diff --git a/hnix-store-remote.cabal b/hnix-store-remote.cabal new file mode 100644 --- /dev/null +++ b/hnix-store-remote.cabal @@ -0,0 +1,52 @@ +name: hnix-store-remote +version: 0.1.0.0 +synopsis: Remote hnix store +description: Implementation of the nix store using the daemon protocol. +homepage: https://github.com/haskell-nix/hnix-store +license: Apache-2.0 +license-file: LICENSE +author: Richard Marko +maintainer: srk@48.io +copyright: 2018 Richard Marko +category: System +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: System.Nix.Store.Remote + , System.Nix.Store.Remote.Logger + , System.Nix.Store.Remote.Protocol + , System.Nix.Store.Remote.Types + , System.Nix.Store.Remote.Util + + build-depends: base >=4.10 && <5 + , base64-bytestring + , bytestring + , binary + , bytestring + , containers + , text + , unix + , network + , mtl + , unordered-containers +-- , pretty-simple +-- , base16-bytestring +-- , base32-bytestring + , hnix-store-core + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable hnix-store-temporary-live-test + main-is: Main.hs + hs-source-dirs: app + build-depends: base + , mtl + , bytestring + , hnix-store-core + , hnix-store-remote + , unordered-containers + , pretty-simple + default-language: Haskell2010 diff --git a/src/System/Nix/Store/Remote.hs b/src/System/Nix/Store/Remote.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module System.Nix.Store.Remote ( + runStore + , isValidPathUncached + , queryValidPaths + , queryAllValidPaths + , querySubstitutablePaths + , querySubstitutablePathInfos + , queryPathInfoUncached + , queryReferrers + , queryValidDerivers + , queryDerivationOutputs + , queryDerivationOutputNames + , queryPathFromHashPart + , addToStoreNar + , addToStore + , addTextToStore + , buildPaths + , buildDerivation + , ensurePath + , addTempRoot + , addIndirectRoot + , syncWithGC + , findRoots + , collectGarbage + , optimiseStore + , verifyStore + , addSignatures + , queryMissing + ) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import qualified Data.Binary as B +import qualified Data.Binary.Put as B +import Data.Maybe +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as M +import Data.Proxy (Proxy(Proxy)) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T + +import qualified System.Nix.Build as Build +import qualified System.Nix.Derivation as Drv +import qualified System.Nix.GC as GC +import System.Nix.Hash (Digest, HashAlgorithm) +import System.Nix.Path +import System.Nix.Hash +import System.Nix.Nar (localPackNar, putNar, narEffectsIO) +import System.Nix.Util + +import System.Nix.Store.Remote.Types +import System.Nix.Store.Remote.Protocol +import System.Nix.Store.Remote.Util + +-- tmp +import qualified Data.ByteString.Base64.Lazy as B64 + +type RepairFlag = Bool +type CheckFlag = Bool +type CheckSigsFlag = Bool +type SubstituteFlag = Bool + +--setOptions :: StoreSetting -> MonadStore () + +isValidPathUncached :: Path -> MonadStore Bool +isValidPathUncached p = simpleOpArgs IsValidPath $ putPath p + +queryValidPaths :: PathSet -> SubstituteFlag -> MonadStore PathSet +queryValidPaths ps substitute = do + runOpArgs QueryValidPaths $ do + putPaths ps + putBool substitute + sockGetPaths + +queryAllValidPaths :: MonadStore PathSet +queryAllValidPaths = do + runOp QueryAllValidPaths + sockGetPaths + +querySubstitutablePaths :: PathSet -> MonadStore PathSet +querySubstitutablePaths ps = do + runOpArgs QuerySubstitutablePaths $ do + putPaths ps + sockGetPaths + +querySubstitutablePathInfos :: PathSet -> MonadStore [SubstitutablePathInfo] +querySubstitutablePathInfos ps = do + runOpArgs QuerySubstitutablePathInfos $ do + putPaths ps + + cnt <- sockGetInt + forM (take cnt $ cycle [(0 :: Int)]) $ pure $ do + _pth <- sockGetPath + drv <- sockGetStr + refs <- sockGetPaths + dlSize <- sockGetInt + narSize' <- sockGetInt + return $ SubstitutablePathInfo { + deriver = mkPath drv + , references = refs + , downloadSize = dlSize + , narSize = narSize' + } + +queryPathInfoUncached :: Path -> MonadStore ValidPathInfo +queryPathInfoUncached p = do + runOpArgs QueryPathInfo $ do + putPath p + + valid <- sockGetBool + unless valid $ error "Path is not valid" + + drv <- sockGetStr + hash' <- lBSToText <$> sockGetStr + refs <- sockGetPaths + regTime <- sockGetInt + size <- sockGetInt + ulti <- sockGetBool + sigs' <- map lBSToText <$> sockGetStrings + ca' <- lBSToText <$> sockGetStr + return $ ValidPathInfo { + path = p + , deriverVP = mkPath drv + , narHash = hash' + , referencesVP = refs + , registrationTime = regTime + , narSizeVP = size + , ultimate = ulti + , sigs = sigs' + , ca = ca' + } + +queryReferrers :: Path -> MonadStore PathSet +queryReferrers p = do + runOpArgs QueryReferrers $ do + putPath p + sockGetPaths + +queryValidDerivers :: Path -> MonadStore PathSet +queryValidDerivers p = do + runOpArgs QueryValidDerivers $ do + putPath p + sockGetPaths + +queryDerivationOutputs :: Path -> MonadStore PathSet +queryDerivationOutputs p = do + runOpArgs QueryDerivationOutputs $ + putPath p + sockGetPaths + +queryDerivationOutputNames :: Path -> MonadStore PathSet +queryDerivationOutputNames p = do + runOpArgs QueryDerivationOutputNames $ + putPath p + sockGetPaths + +-- XXX: this is broken as I don't know how to get hashes from paths (fix mkPath) +queryPathFromHashPart :: Digest PathHashAlgo -> MonadStore (Maybe Path) +queryPathFromHashPart d = do + runOpArgs QueryPathFromHashPart $ + -- TODO: replace `undefined` with digest encoding function when + -- [issue 24](https://github.com/haskell-nix/hnix-store/issues/24) is + -- closed + putByteStringLen $ LBS.fromStrict $ undefined d + sockGetPath + +type Source = () -- abstract binary source +addToStoreNar :: ValidPathInfo -> Source -> RepairFlag -> CheckSigsFlag -> MonadStore () +addToStoreNar = undefined -- XXX + +type PathFilter = Path -> Bool + +addToStore + :: forall a. (ValidAlgo a, NamedAlgo a) + => LBS.ByteString + -> FilePath + -> Bool + -> Proxy a + -> PathFilter + -> RepairFlag + -> MonadStore Path +addToStore name pth recursive algoProxy pfilter repair = do + + -- TODO: Is this lazy enough? We need `B.putLazyByteString bs` to stream `bs` + bs :: LBS.ByteString <- liftIO $ B.runPut . putNar <$> localPackNar narEffectsIO pth + + runOpArgs AddToStore $ do + putByteStringLen name + putInt 1 + if recursive + then putInt 1 + else putInt 0 + + putByteStringLen (T.encodeUtf8 . T.toLower . T.fromStrict $ algoName @a) + + B.putLazyByteString bs + + fmap (fromMaybe $ error "TODO: Error") sockGetPath + + +addTextToStore :: LBS.ByteString -> LBS.ByteString -> PathSet -> RepairFlag -> MonadStore (Maybe Path) +addTextToStore name text references' repair = do + runOpArgs AddTextToStore $ do + putByteStringLen name + putByteStringLen text + putPaths references' + sockGetPath + +buildPaths :: PathSet -> Build.BuildMode -> MonadStore () +buildPaths ps bm = void $ simpleOpArgs EnsurePath $ do + putPaths ps + putInt $ fromEnum bm + +buildDerivation :: PathName -> Drv.Derivation -> Build.BuildMode -> MonadStore Build.BuildResult +buildDerivation = undefined -- XXX + +ensurePath :: Path -> MonadStore () +ensurePath pn = void $ simpleOpArgs EnsurePath $ putPath pn + +addTempRoot :: Path -> MonadStore () +addTempRoot pn = void $ simpleOpArgs AddTempRoot $ putPath pn + +addIndirectRoot :: Path -> MonadStore () +addIndirectRoot pn = void $ simpleOpArgs AddIndirectRoot $ putPath pn + +syncWithGC :: MonadStore () +syncWithGC = void $ simpleOp SyncWithGC + +findRoots :: MonadStore Roots +findRoots = do + runOp FindRoots + res <- getSocketIncremental (do + count <- getInt + res <- sequence $ replicate count ((,) <$> getPath <*> getPath) + return res + ) + + return $ M.fromList $ catMaybesTupled res + where + catMaybesTupled :: [(Maybe a, Maybe b)] -> [(a, b)] + catMaybesTupled ls = map (\(Just x, Just y) -> (x, y)) $ filter (\(x,y) -> isJust x && isJust y) ls + +collectGarbage :: GC.Options -> MonadStore GC.Result +collectGarbage opts = do + runOpArgs CollectGarbage $ do + putInt $ fromEnum $ GC.operation opts + putPaths $ GC.pathsToDelete opts + putBool $ GC.ignoreLiveness opts + putInt $ GC.maxFreed opts + forM_ [(0 :: Int)..2] $ pure $ putInt (0 :: Int) -- removed options + + paths <- sockGetPaths + freed <- sockGetInt + _obsolete <- sockGetInt :: MonadStore Int + + return $ GC.Result paths freed + +optimiseStore :: MonadStore () +optimiseStore = void $ simpleOp OptimiseStore + +-- returns True on errors +verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool +verifyStore check repair = simpleOpArgs VerifyStore $ do + putBool check + putBool repair + +addSignatures :: Path -> [LBS.ByteString] -> MonadStore () +addSignatures p signatures = void $ simpleOpArgs AddSignatures $ do + putPath p + putByteStrings signatures + +-- TODO: +queryMissing :: PathSet -> MonadStore (PathSet, PathSet, PathSet, Integer, Integer) +queryMissing ps = undefined -- willBuild willSubstitute unknown downloadSize narSize + + diff --git a/src/System/Nix/Store/Remote/Logger.hs b/src/System/Nix/Store/Remote/Logger.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Logger.hs @@ -0,0 +1,60 @@ +module System.Nix.Store.Remote.Logger ( + Logger(..) + , Field(..) + , processOutput) + where + +import Control.Monad.Reader (ask, liftIO) +import Data.Binary.Get + +import Network.Socket.ByteString (recv) + +import System.Nix.Store.Remote.Types +import System.Nix.Util + +controlParser :: Get Logger +controlParser = do + ctrl <- getInt + case (ctrl :: Int) of + 0x6f6c6d67 -> Next <$> getByteStringLen + 0x64617461 -> Read <$> getInt + 0x64617416 -> Write <$> getByteStringLen + 0x616c7473 -> pure Last + 0x63787470 -> flip Error <$> getByteStringLen <*> getInt + 0x53545254 -> StartActivity <$> getInt <*> getInt <*> getInt <*> getByteStringLen <*> getFields <*> getInt + 0x53544f50 -> StopActivity <$> getInt + 0x52534c54 -> Result <$> getInt <*> getInt <*> getFields + x -> fail $ "Invalid control message received:" ++ show x + +processOutput :: MonadStore [Logger] +processOutput = go decoder + where decoder = runGetIncremental controlParser + go :: Decoder Logger -> MonadStore [Logger] + go (Done _leftover _consumed ctrl) = do + case ctrl of + e@(Error _ _) -> return [e] + Last -> return [Last] + -- we should probably handle Read here as well + x -> do + next <- go decoder + return $ x:next + go (Partial k) = do + soc <- ask + chunk <- liftIO (Just <$> recv soc 8) + go (k chunk) + + go (Fail _leftover _consumed msg) = do + error msg + +getFields :: Get [Field] +getFields = do + cnt <- getInt + sequence $ replicate cnt getField + +getField :: Get Field +getField = do + typ <- getInt + case (typ :: Int) of + 0 -> LogInt <$> getInt + 1 -> LogStr <$> getByteStringLen + x -> fail $ "Unknown log type: " ++ show x diff --git a/src/System/Nix/Store/Remote/Protocol.hs b/src/System/Nix/Store/Remote/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Protocol.hs @@ -0,0 +1,170 @@ +module System.Nix.Store.Remote.Protocol ( + WorkerOp(..) + , simpleOp + , simpleOpArgs + , runOp + , runOpArgs + , runStore) where + +import Control.Exception (bracket) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS + +import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Network.Socket.ByteString (recv) + +import System.Nix.Store.Remote.Logger +import System.Nix.Store.Remote.Types +import System.Nix.Store.Remote.Util +import System.Nix.Util + +protoVersion :: Int +protoVersion = 0x115 +-- major protoVersion & 0xFF00 +-- minor .. & 0x00FF + +workerMagic1 :: Int +workerMagic1 = 0x6e697863 +workerMagic2 :: Int +workerMagic2 = 0x6478696f + +sockPath :: String +sockPath = "/nix/var/nix/daemon-socket/socket" + +data WorkerOp = + IsValidPath + | HasSubstitutes + | QueryReferrers + | AddToStore + | AddTextToStore + | BuildPaths + | EnsurePath + | AddTempRoot + | AddIndirectRoot + | SyncWithGC + | FindRoots + | SetOptions + | CollectGarbage + | QuerySubstitutablePathInfo + | QueryDerivationOutputs + | QueryAllValidPaths + | QueryFailedPaths + | ClearFailedPaths + | QueryPathInfo + | QueryDerivationOutputNames + | QueryPathFromHashPart + | QuerySubstitutablePathInfos + | QueryValidPaths + | QuerySubstitutablePaths + | QueryValidDerivers + | OptimiseStore + | VerifyStore + | BuildDerivation + | AddSignatures + | NarFromPath + | AddToStoreNar + | QueryMissing + deriving (Eq, Ord, Show) + +opNum :: WorkerOp -> Int +opNum IsValidPath = 1 +opNum HasSubstitutes = 3 +opNum QueryReferrers = 6 +opNum AddToStore = 7 +opNum AddTextToStore = 8 +opNum BuildPaths = 9 +opNum EnsurePath = 10 +opNum AddTempRoot = 11 +opNum AddIndirectRoot = 12 +opNum SyncWithGC = 13 +opNum FindRoots = 14 +opNum SetOptions = 19 +opNum CollectGarbage = 20 +opNum QuerySubstitutablePathInfo = 21 +opNum QueryDerivationOutputs = 22 +opNum QueryAllValidPaths = 23 +opNum QueryFailedPaths = 24 +opNum ClearFailedPaths = 25 +opNum QueryPathInfo = 26 +opNum QueryDerivationOutputNames = 28 +opNum QueryPathFromHashPart = 29 +opNum QuerySubstitutablePathInfos = 30 +opNum QueryValidPaths = 31 +opNum QuerySubstitutablePaths = 32 +opNum QueryValidDerivers = 33 +opNum OptimiseStore = 34 +opNum VerifyStore = 35 +opNum BuildDerivation = 36 +opNum AddSignatures = 37 +opNum NarFromPath = 38 +opNum AddToStoreNar = 39 +opNum QueryMissing = 40 + + +simpleOp :: WorkerOp -> MonadStore Bool +simpleOp op = do + simpleOpArgs op $ return () + +simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool +simpleOpArgs op args = do + runOpArgs op args + err <- gotError + case err of + True -> do + Error _num msg <- head <$> getError + throwError $ BSC.unpack $ LBS.toStrict msg + False -> do + sockGetBool + +runOp :: WorkerOp -> MonadStore () +runOp op = runOpArgs op $ return () + +runOpArgs :: WorkerOp -> Put -> MonadStore () +runOpArgs op args = do + + -- Temporary hack for printing the messages destined for nix-daemon socket + when False $ + liftIO $ LBS.writeFile "mytestfile2" $ runPut $ do + putInt $ opNum op + args + + sockPut $ do + putInt $ opNum op + args + + out <- processOutput + modify (++out) + err <- gotError + when err $ do + Error _num msg <- head <$> getError + throwError $ BSC.unpack $ LBS.toStrict msg + +runStore :: MonadStore a -> IO (Either String a, [Logger]) +runStore code = do + bracket (open sockPath) close run + where + open path = do + soc <- socket AF_UNIX Stream 0 + connect soc (SockAddrUnix path) + return soc + greet = do + sockPut $ putInt workerMagic1 + soc <- ask + vermagic <- liftIO $ recv soc 16 + let (magic2, daemonProtoVersion) = flip runGet (LBS.fromStrict vermagic) $ (,) <$> getInt <*> getInt + unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch" + + sockPut $ putInt protoVersion -- clientVersion + sockPut $ putInt (0 :: Int) -- affinity + sockPut $ putInt (0 :: Int) -- obsolete reserveSpace + + processOutput + + run sock = + flip runReaderT sock $ flip runStateT [] $ runExceptT (greet >> code) diff --git a/src/System/Nix/Store/Remote/Types.hs b/src/System/Nix/Store/Remote/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Types.hs @@ -0,0 +1,53 @@ +module System.Nix.Store.Remote.Types ( + MonadStore + , Logger(..) + , Field(..) + , getLog + , flushLog + , gotError + , getError) where + + +import qualified Data.ByteString.Lazy as LBS +import Network.Socket (Socket) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +type MonadStore a = ExceptT String (StateT [Logger] (ReaderT Socket IO)) a + +type ActivityID = Int +type ActivityParentID = Int +type ActivityType = Int +type Verbosity = Int +type ResultType = Int + +data Field = LogStr LBS.ByteString | LogInt Int + deriving (Eq, Ord, Show) + +data Logger = + Next LBS.ByteString + | Read Int -- data needed from source + | Write LBS.ByteString -- data for sink + | Last + | Error Int LBS.ByteString + | StartActivity ActivityID Verbosity ActivityType LBS.ByteString [Field] ActivityParentID + | StopActivity ActivityID + | Result ActivityID ResultType [Field] + deriving (Eq, Ord, Show) + +isError :: Logger -> Bool +isError (Error _ _) = True +isError _ = False + +gotError :: MonadStore Bool +gotError = any isError <$> get + +getError :: MonadStore [Logger] +getError = filter isError <$> get + +getLog :: MonadStore [Logger] +getLog = get + +flushLog :: MonadStore () +flushLog = put [] diff --git a/src/System/Nix/Store/Remote/Util.hs b/src/System/Nix/Store/Remote/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Store/Remote/Util.hs @@ -0,0 +1,103 @@ +module System.Nix.Store.Remote.Util where + +import Control.Monad.Reader + +import Data.Maybe +import Data.Binary.Get +import Data.Binary.Put +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashSet as HashSet + +import Network.Socket.ByteString (recv, sendAll) + +import System.Nix.Store.Remote.Types +import System.Nix.Hash +import System.Nix.Path +import System.Nix.Util + + +genericIncremental :: (MonadIO m) => m (Maybe B.ByteString) -> Get a -> m a +genericIncremental getsome parser = go decoder + where decoder = runGetIncremental parser + go (Done _leftover _consumed x) = do + return x + go (Partial k) = do + chunk <- getsome + go (k chunk) + go (Fail _leftover _consumed msg) = do + error msg + +getSocketIncremental :: Get a -> MonadStore a +getSocketIncremental = genericIncremental sockGet + +sockPut :: Put -> MonadStore () +sockPut p = do + soc <- ask + liftIO $ sendAll soc $ LBS.toStrict $ runPut p + +sockGet :: MonadStore (Maybe BSC.ByteString) +sockGet = do + soc <- ask + liftIO $ Just <$> recv soc 8 + +sockGetPath :: MonadStore (Maybe Path) +sockGetPath = getSocketIncremental getPath + +sockGetPaths :: MonadStore PathSet +sockGetPaths = getSocketIncremental getPaths + +sockGetInt :: Integral a => MonadStore a +sockGetInt = getSocketIncremental getInt + +sockGetBool :: MonadStore Bool +sockGetBool = (== (1 :: Int)) <$> sockGetInt + +sockGetStr :: MonadStore LBS.ByteString +sockGetStr = getSocketIncremental getByteStringLen + +sockGetStrings :: MonadStore [LBS.ByteString] +sockGetStrings = getSocketIncremental getByteStrings + +lBSToText :: LBS.ByteString -> Text +lBSToText = T.pack . BSC.unpack . LBS.toStrict + +textToLBS :: Text -> LBS.ByteString +textToLBS = LBS.fromStrict . BSC.pack . T.unpack + +-- XXX: needs work +mkPath :: LBS.ByteString -> Maybe Path +mkPath p = case (pathName $ lBSToText p) of + -- TODO: replace `undefined` with digest encoding function when + -- [issue 24](https://github.com/haskell-nix/hnix-store/issues/24) + -- is closed + Just x -> Just $ Path (hash $ LBS.toStrict p) x --XXX: hash + Nothing -> Nothing + +-- WOOT +-- import Data.ByteString.Base32 as Base32 +--drvP = Path (fromJust $ digestFromByteString $ pls $ Base32.decode $ BSC.take 32 $ BSC.drop (BSC.length "/nix/store/") drv) (fromJust $ pathName $ T.pack $ BSC.unpack drv) +--pls (Left _) = error "unable to decode hash" +--pls (Right x) = x + +getPath :: Get (Maybe Path) +getPath = mkPath <$> getByteStringLen + +getPaths :: Get PathSet +getPaths = HashSet.fromList . catMaybes . map mkPath <$> getByteStrings + +putPathName :: PathName -> Put +putPathName = putByteStringLen . textToLBS . pathNameContents + +putPath :: Path -> Put +putPath (Path _hash name) = putPathName name + +putPaths :: PathSet -> Put +putPaths = putByteStrings . HashSet.map (\(Path _hash name) -> textToLBS $ pathNameContents name) + +putBool :: Bool -> Put +putBool True = putInt (1 :: Int) +putBool False = putInt (0 :: Int)