2 files changed, 62 insertions(+), 42 deletions(-)

M orchid.cabal
M src/Command/Pin.hs

@@ 48,6 48,7 @@ library
                          || ^>= 1.12.1
                      , cryptohash-sha256 ^>= 0.11.101
                      , unix ^>= 2.7.2
+                     , mtl ^>= 2.3
   hs-source-dirs:      src
 
 executable orchid

@@ 1,4 1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Command.Pin where
 
 import Command (Command(Pin))


@@ 40,6 41,9 @@ import Crypto.Hash.SHA256 (hash)
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 
+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+
 
 data PinContext = PinContext
   { targets :: [FilePath]


@@ 51,6 55,14 @@ data PinContext = PinContext
   , startTime :: UTCTime
   , storeContents :: StoreContents }
 
+
+-- TODO state = type PinState = BimapMany FilePath Hash ()
+newtype PinM a = PinM { runPin' :: ReaderT (BaseContext, PinContext) IO a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadReader (BaseContext, PinContext))
+
+runPin :: BaseContext -> PinContext -> PinM a -> IO a
+runPin baseCtx pinCtx = flip runReaderT (baseCtx, pinCtx) . runPin'
+
 pinCommand :: Mod CommandFields Command
 pinCommand = command "pin" (info (Pin <$> pinOptions)
   ( progDesc "Pin the store paths used by files in the specified paths" ))


@@ 58,13 70,16 @@ pinCommand = command "pin" (info (Pin <$> pinOptions)
 pinAction :: BaseContext -> PinOptions -> IO ()
 pinAction baseCtx pinOpts = do
   pinCtx <- establishPinContext baseCtx pinOpts
-  cleanLinks pinCtx
-  traverseFileTrees (processFile baseCtx pinCtx) $ targets pinCtx
-  updateLastExecution pinCtx
+  runPin baseCtx pinCtx $ do
+    cleanLinks
+    traverseFileTrees processFile $ targets pinCtx
+    updateLastExecution
 
-updateLastExecution :: PinContext -> IO ()
-updateLastExecution pinCtx =
-  setModificationTime (lastExecutionFile pinCtx) $ startTime pinCtx
+updateLastExecution :: PinM ()
+updateLastExecution = do
+  time <- asks (startTime . snd)
+  file <- asks (lastExecutionFile . snd)
+  liftIO $ setModificationTime file time
 
 establishPinContext :: BaseContext -> PinOptions -> IO PinContext
 establishPinContext baseCtx pinOpts = do


@@ 95,29 110,31 @@ getDefaultGcrootsPath = do
   userName <- getEffectiveUserName
   pure $ "/nix/var/nix/gcroots/per-user" </> userName </> "orchid"
 
-processFile :: BaseContext -> PinContext -> FilePath -> IO ()
-processFile baseCtx pinCtx source = do
-  let hashed = bsHex $ hash $ fromString source
-      target = gcrootsDir pinCtx </> hashed
-  fileMod <- getModificationTime source
-  when (fileMod > lastExecution pinCtx) $ do
-    isLink <- pathIsSymbolicLink source
-    storePaths <- if isLink
-      then do
-        linkTarget <- getSymbolicLinkTarget source
-        let maybeHash = hashFromPath (storeDir baseCtx) linkTarget
-            maybeStorePath = maybeHash >>= lookupHash (storeContents pinCtx)
-        pure $ maybeToList maybeStorePath
-      else do
-        -- TODO check that it's a normal file (could be a socket or other special file)
-        contents <- LBS.readFile source
-        pure $ mapMaybe (lookupHash $ storeContents pinCtx)
-             $ nubOrd
-             $ findStoreHashes (storeDir baseCtx) contents
-    unless (null storePaths) $ do
-      createDirectoryIfMissing True $ target </> "roots"
-      createFileLink source $ target </> "source"
-      traverse_ (linkPath $ target </> "roots") storePaths
+processFile :: FilePath -> PinM ()
+processFile source = do
+  (baseCtx, pinCtx) <- ask
+  liftIO $ do
+    let hashed = bsHex $ hash $ fromString source
+        target = gcrootsDir pinCtx </> hashed
+    fileMod <- getModificationTime source
+    when (fileMod > lastExecution pinCtx) $ do
+      isLink <- pathIsSymbolicLink source
+      storePaths <- if isLink
+        then do
+          linkTarget <- getSymbolicLinkTarget source
+          let maybeHash = hashFromPath (storeDir baseCtx) linkTarget
+              maybeStorePath = maybeHash >>= lookupHash (storeContents pinCtx)
+          pure $ maybeToList maybeStorePath
+        else do
+          -- TODO check that it's a normal file (could be a socket or other special file)
+          contents <- LBS.readFile source
+          pure $ mapMaybe (lookupHash $ storeContents pinCtx)
+              $ nubOrd
+              $ findStoreHashes (storeDir baseCtx) contents
+      unless (null storePaths) $ do
+        createDirectoryIfMissing True $ target </> "roots"
+        createFileLink source $ target </> "source"
+        traverse_ (linkPath $ target </> "roots") storePaths
 
 linkPath :: FilePath -> (Hash, FilePath) -> IO ()
 linkPath targetDir (hashed, storePath) = do


@@ 131,16 148,18 @@ linkPath targetDir (hashed, storePath) = do
     , storePath ]
     mempty
 
-cleanLinks :: PinContext -> IO ()
-cleanLinks pinCtx = do
-  ls <- listDirectory $ gcrootsDir pinCtx
-  forM_ ls $ \entry -> do
-    entrySource <- getSymbolicLinkTarget (gcrootsDir pinCtx </> entry </> "source")
-    shouldRemove <- do
-      sourceExists <- doesFileExist entrySource
-      if sourceExists
-      then do
-        entryMod <- getModificationTime entrySource
-        pure $ entryMod > lastExecution pinCtx
-      else pure True
-    when shouldRemove $ removeDirectoryRecursive $ gcrootsDir pinCtx </> entry
+cleanLinks :: PinM ()
+cleanLinks = do
+  (_, pinCtx) <- ask
+  liftIO $ do
+    ls <- listDirectory $ gcrootsDir pinCtx
+    forM_ ls $ \entry -> do
+      entrySource <- getSymbolicLinkTarget (gcrootsDir pinCtx </> entry </> "source")
+      shouldRemove <- do
+        sourceExists <- doesFileExist entrySource
+        if sourceExists
+        then do
+          entryMod <- getModificationTime entrySource
+          pure $ entryMod > lastExecution pinCtx
+        else pure True
+      when shouldRemove $ removeDirectoryRecursive $ gcrootsDir pinCtx </> entry