mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
server: -funroll-gadt
This commit is contained in:
parent
960407b0a1
commit
bb9bc1705a
@ -15,7 +15,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
|
|||||||
import Data.Default.Class (Default(def))
|
import Data.Default.Class (Default(def))
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
import Data.IORef (IORef, atomicModifyIORef, newIORef)
|
import Data.IORef (IORef, atomicModifyIORef, newIORef)
|
||||||
import Data.Some (Some(Some))
|
--import Data.Some (Some(Some))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Void (Void, absurd)
|
import Data.Void (Void, absurd)
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
@ -33,8 +33,7 @@ import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), Server
|
|||||||
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
||||||
|
|
||||||
-- wip
|
-- wip
|
||||||
-- import Data.Some (traverseSome)
|
import Data.Some (withSome)
|
||||||
import Data.Functor.Identity
|
|
||||||
|
|
||||||
type WorkerHelper m
|
type WorkerHelper m
|
||||||
= forall a
|
= forall a
|
||||||
@ -107,7 +106,7 @@ processConnection workerHelper sock = do
|
|||||||
, StoreReply a
|
, StoreReply a
|
||||||
)
|
)
|
||||||
=> StoreRequest a
|
=> StoreRequest a
|
||||||
-> RemoteStoreT m (Identity a)
|
-> RemoteStoreT m ()
|
||||||
perform req = do
|
perform req = do
|
||||||
resp <- bracketLogger tunnelLogger $ lift $ workerHelper req
|
resp <- bracketLogger tunnelLogger $ lift $ workerHelper req
|
||||||
sockPutS
|
sockPutS
|
||||||
@ -116,7 +115,6 @@ processConnection workerHelper sock = do
|
|||||||
$ getReplyS
|
$ getReplyS
|
||||||
)
|
)
|
||||||
resp
|
resp
|
||||||
pure (Identity resp)
|
|
||||||
|
|
||||||
-- Process client requests.
|
-- Process client requests.
|
||||||
let loop = do
|
let loop = do
|
||||||
@ -126,26 +124,34 @@ processConnection workerHelper sock = do
|
|||||||
RemoteStoreError_SerializerRequest
|
RemoteStoreError_SerializerRequest
|
||||||
storeRequest
|
storeRequest
|
||||||
|
|
||||||
-- • Could not deduce (Show a) arising from a use of ‘perform’
|
-- have to be explicit here
|
||||||
-- and also (StoreReply a)
|
-- because otherwise GHC can't conjure Show a, StoreReply a
|
||||||
-- traverseSome perform someReq
|
-- out of thin air
|
||||||
void $ do
|
() <- withSome someReq $ \case
|
||||||
case someReq of
|
r@AddToStore {} -> perform r
|
||||||
Some req@(IsValidPath {}) -> do
|
r@AddTextToStore {} -> perform r
|
||||||
-- • Couldn't match type ‘a0’ with ‘Bool’
|
r@AddSignatures {} -> perform r
|
||||||
-- Expected: StoreRequest a0
|
r@AddTempRoot {} -> perform r
|
||||||
-- Actual: StoreRequest a
|
r@AddIndirectRoot {} -> perform r
|
||||||
-- • ‘a0’ is untouchable
|
r@BuildDerivation {} -> perform r
|
||||||
-- inside the constraints: a ~ Bool
|
r@BuildPaths {} -> perform r
|
||||||
-- bound by a pattern with constructor:
|
r@CollectGarbage {} -> perform r
|
||||||
-- IsValidPath :: StorePath -> StoreRequest Bool
|
r@EnsurePath {} -> perform r
|
||||||
-- runIdentity <$> perform req
|
r@FindRoots {} -> perform r
|
||||||
|
r@IsValidPath {} -> perform r
|
||||||
void $ perform req
|
r@QueryValidPaths {} -> perform r
|
||||||
pure undefined
|
r@QueryAllValidPaths {} -> perform r
|
||||||
|
r@QuerySubstitutablePaths {} -> perform r
|
||||||
_ -> throwError unimplemented
|
r@QueryPathInfo {} -> perform r
|
||||||
|
r@QueryReferrers {} -> perform r
|
||||||
|
r@QueryValidDerivers {} -> perform r
|
||||||
|
r@QueryDerivationOutputs {} -> perform r
|
||||||
|
r@QueryDerivationOutputNames {} -> perform r
|
||||||
|
r@QueryPathFromHashPart {} -> perform r
|
||||||
|
r@QueryMissing {} -> perform r
|
||||||
|
r@OptimiseStore {} -> perform r
|
||||||
|
r@SyncWithGC {} -> perform r
|
||||||
|
r@VerifyStore {} -> perform r
|
||||||
loop
|
loop
|
||||||
loop
|
loop
|
||||||
|
|
||||||
@ -223,9 +229,9 @@ processConnection workerHelper sock = do
|
|||||||
, serverHandshakeOutputClientVersion = clientVersion
|
, serverHandshakeOutputClientVersion = clientVersion
|
||||||
}
|
}
|
||||||
|
|
||||||
{-# WARNING unimplemented "not yet implemented" #-}
|
{-# WARNING _unimplemented "not yet implemented" #-}
|
||||||
unimplemented :: RemoteStoreError
|
_unimplemented :: RemoteStoreError
|
||||||
unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented
|
_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented
|
||||||
|
|
||||||
bracketLogger
|
bracketLogger
|
||||||
:: MonadRemoteStore m
|
:: MonadRemoteStore m
|
||||||
|
Loading…
Reference in New Issue
Block a user