hnix-store-remote prototype

hnix-store-remote/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.

hnix-store-remote/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
+```

hnix-store-remote/hnix-store-remote.cabal

@@ -0,0 +1,40 @@
+name:                hnix-store-remote
+version:             0.1.0.0
+synopsis:            Remote hnix store
+description:
+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:  ChangeLog.md, 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
+
+  build-depends:       base >=4.10 && <4.11
+                     , bytestring
+                     , binary
+                     , bytestring
+                     , containers
+                     , text
+                     , unix
+                     , network
+                     , mtl
+                     , cryptonite
+                     , unordered-containers
+                     , memory
+--                   , pretty-simple
+--                   , base16-bytestring
+--                   , base32-bytestring
+                     , hnix-store-core
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall

hnix-store-remote/src/System/Nix/Store/Remote.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE OverloadedStrings   #-}
+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           Data.Maybe
+import           Data.ByteArray            (convert)
+import qualified Data.ByteString.Lazy      as LBS
+import qualified Data.Map.Strict           as M
+
+import           Control.Monad
+
+import qualified System.Nix.Build      as Build
+import qualified System.Nix.Derivation as Drv
+import qualified System.Nix.GC         as GC
+import           System.Nix.Path
+import           System.Nix.Util
+
+import           System.Nix.Store.Remote.Types
+import           System.Nix.Store.Remote.Protocol
+import           System.Nix.Store.Remote.Util
+
+import           Crypto.Hash
+
+type RepairFlag = Bool
+type CheckFlag = Bool
+type CheckSigsFlag = Bool
+type SubstituteFlag = Bool
+
+-- TODO: error handling via ErrorT, some of these will just log Error,
+-- which means we need to bail out and not wait for results
+--
+--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 $
+    putByteStringLen $ LBS.fromStrict $ convert d
+  sockGetPath
+
+type Source = () -- abstract binary source
+addToStoreNar :: ValidPathInfo -> Source -> RepairFlag -> CheckSigsFlag -> MonadStore ()
+addToStoreNar = undefined  -- XXX
+
+type PathFilter = Path -> Bool
+addToStore :: LBS.ByteString -> Path -> Bool -> PathHashAlgo -> PathFilter -> RepairFlag -> MonadStore Path
+addToStore name pth recursive hashAlgo pfilter repair = undefined -- XXX
+
+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.BasicDerivation -> 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
+
+

hnix-store-remote/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

hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs

@@ -0,0 +1,155 @@
+module System.Nix.Store.Remote.Protocol (
+    WorkerOp(..)
+  , simpleOp
+  , simpleOpArgs
+  , runOp
+  , runOpArgs
+  , runStore) where
+
+import           Control.Exception         (bracket)
+import           Control.Monad.Reader
+import           Control.Monad.State
+
+import           Data.Binary.Get
+import           Data.Binary.Put
+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 -> return False  -- XXX: ErrorT?
+    False -> do
+      sockGetBool
+
+runOp :: WorkerOp -> MonadStore ()
+runOp op = runOpArgs op $ return ()
+
+runOpArgs :: WorkerOp -> Put -> MonadStore ()
+runOpArgs op args = do
+  sockPut $ do
+    putInt $ opNum op
+    args
+
+  out <- processOutput
+  put out
+
+runStore :: MonadStore a -> IO (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 [] (greet >> code)

hnix-store-remote/src/System/Nix/Store/Remote/Types.hs

@@ -0,0 +1,40 @@
+module System.Nix.Store.Remote.Types (
+    MonadStore
+  , Logger(..)
+  , Field(..)
+  , gotError) where
+
+
+import qualified Data.ByteString.Lazy      as LBS
+import           Network.Socket            (Socket)
+import           Control.Monad.Reader
+import           Control.Monad.State
+
+type MonadStore a = 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

hnix-store-remote/src/System/Nix/Store/Remote/Util.hs

@@ -0,0 +1,100 @@
+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.Path
+import           System.Nix.Util
+
+import           Crypto.Hash
+
+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
+             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)