@@ -1,28 +1,30 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE StaticPointers #-}
34{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE TypeApplications #-}
46module Obelisk.Command where
57
68import System.Process ()
7−import Control.Concurrent
8−import Control.Distributed.Process hiding (finally)
9−import Control.Distributed.Process.Closure
10−import Control.Distributed.Process.Node (initRemoteTable, runProcess)
11−import Control.Distributed.Process.Backend.SimpleLocalnet
129import Control.Monad
13−import Control.Monad.Catch
10+import qualified Data.Binary as Binary
11+import qualified Data.ByteString.Base16 as Base16
12+import qualified Data.ByteString.Lazy as LBS
1413import Data.Either
1514import Data.Foldable
1615import Data.List
1716import qualified Data.List.NonEmpty as NE
1817import Data.Maybe
1918import Data.Monoid
19+import qualified Data.Text as T
20+import Data.Text.Encoding
2021import Distribution.Utils.Generic (withUTF8FileContents)
2122import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))
2223import Distribution.Types.BuildInfo
2324import Distribution.Types.CondTree
2425import Distribution.Types.Library
2526import Distribution.Types.GenericPackageDescription
27+import GHC.StaticPtr
2628import Options.Applicative
2729import System.Directory
2830import System.Environment
@@ -87,14 +89,6 @@ parseHsSrcDir cabalFp = do
8789 ParseFailed _ -> return Nothing
8890 else return Nothing
8991
90−ghcidAction :: () -> Process ()
91−ghcidAction () = liftIO run
92−
93−remotable ['ghcidAction]
94−
95−obRemoteTable :: RemoteTable
96−obRemoteTable = Obelisk.Command.__remoteTable initRemoteTable
97−
9892data Args = Args
9993 { _args_noHandOffPassed :: Bool
10094 -- ^ This flag is actually handled outside of the optparse-applicative parser, but we detect whether
@@ -135,29 +129,17 @@ data ObCommand
135129 | ObCommand_Internal ObInternal
136130
137131data ObInternal
138− = ObInternal_Daemon
139−
140−inNixShell :: Closure (Process ()) -> IO ()
141−inNixShell m = withProjectRoot "." $ \root -> do
142− progName <- getProgName
143− _ <- forkIO $ projectShell root False "ghc" $ unwords [progName, "internal", "daemon"]
144− backend <- initializeBackend "127.0.0.1" "0" obRemoteTable
145− backendNode <- newLocalNode backend
146− startMaster backend (daemonMaster backend m) `finally`
147− runProcess backendNode (terminateAllSlaves backend)
148−
149−daemonMaster :: Backend -> Closure (Process ()) -> [NodeId] -> Process ()
150−daemonMaster backend p [] = do
151− slaves <- findSlaves backend
152− daemonMaster backend p $ processNodeId <$> slaves
153−daemonMaster _ p nodeIds = do
154− forM_ nodeIds $ \nodeId -> do
155− _pid <- spawnLink nodeId p
156− return ()
157− expect
132+ = ObInternal_RunStaticIO StaticKey
158133
159−daemonSlave :: IO ()
160−daemonSlave = startSlave =<< initializeBackend "127.0.0.1" "0" obRemoteTable
134+inNixShell' :: StaticPtr (IO ()) -> IO ()
135+inNixShell' p = withProjectRoot "." $ \root -> do
136+ progName <- getExecutablePath
137+ projectShell root False "ghc" $ unwords --TODO: shell escape
138+ [ progName
139+ , "internal"
140+ , "run-static-io"
141+ , encodeStaticKey $ staticKey p
142+ ]
161143
162144obCommand :: Parser ObCommand
163145obCommand = hsubparser
@@ -176,7 +158,7 @@ obCommand = hsubparser
176158
177159internalCommand :: Parser ObInternal
178160internalCommand = subparser $ mconcat
179− [ command "daemon" $ info (pure ObInternal_Daemon) mempty
161+ [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty
180162 ]
181163
182164--TODO: Result should provide normalised path and also original user input for error reporting.
@@ -245,21 +227,30 @@ main = do
245227 | otherwise -> handoffAndGo (a:as)
246228 as -> handoffAndGo as
247229
248−replyBack :: (ProcessId, String) -> Process ()
249−replyBack (sender, msg) = send sender msg
250−
251−logMessage :: String -> Process ()
252−logMessage msg = say $ "handling " ++ msg
253−
254230ob :: ObCommand -> IO ()
255231ob = \case
256232 ObCommand_Init source -> initProject source
257− ObCommand_Run -> inNixShell ($(mkClosure 'ghcidAction) ())
233+ ObCommand_Run -> inNixShell' $ static run
234+ -- inNixShell ($(mkClosure 'ghcidAction) ())
258235 ObCommand_Thunk tc -> case tc of
259236 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks
260237 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks
261238 ThunkCommand_Pack thunks -> forM_ thunks $ \(ThunkPackOpts dir upstream) -> packThunk dir upstream
262239 ObCommand_Repl component -> runRepl component
263240 ObCommand_Watch component -> watch component
264− ObCommand_Internal ObInternal_Daemon -> daemonSlave
241+ ObCommand_Internal icmd -> case icmd of
242+ ObInternal_RunStaticIO k -> unsafeLookupStaticPtr @(IO ()) k >>= \case
243+ Nothing -> fail $ "ObInternal_RunStaticIO: no such StaticKey: " <> show k
244+ Just p -> deRefStaticPtr p
265245--TODO: Clean up all the magic strings throughout this codebase
246+
247+encodeStaticKey :: StaticKey -> String
248+encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode
249+
250+decodeStaticKey :: String -> Either String StaticKey
251+decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
252+ (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
253+ Right ("", _, a) -> pure a
254+ Right _ -> fail $ "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
255+ Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
256+ _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s