WIP usage of store in stack

src/Data/Store/VersionTagged.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+-- | Tag a Store instance with structural version info to ensure we're
+-- reading a compatible format.
+module Data.Store.VersionTagged
+    ( taggedDecodeOrLoad
+    , taggedEncodeFile
+    , decodeFileMaybe
+    ) where
+
+import Control.Exception.Lifted (catch, IOException, assert)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Logger
+import Control.Monad.Trans.Control (MonadBaseControl)
+import qualified Data.ByteString as BS
+import Data.Monoid ((<>))
+import Data.Store
+import Data.Store.TypeHash
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Path
+import Path.IO (ensureDir)
+
+-- | Write to the given file, with a binary-tagged tag.
+taggedEncodeFile :: (Store a, HasTypeHash a, MonadIO m, MonadLogger m, Eq a)
+                 => Path Abs File
+                 -> a
+                 -> m ()
+taggedEncodeFile fp x = do
+    let fpt = T.pack (toFilePath fp)
+    $logDebug $ "Encoding " <> fpt
+    ensureDir (parent fp)
+    let encoded = encode (Tagged x)
+    -- liftIO $ BS.appendFile "encode-log" $ encodeUtf8 fpt <> " is " <> encoded <> "DONE"
+    -- $logDebug $ "Encoded: " <> decodeUtf8 (B16.encode encoded)
+    assert (decodeEx encoded == Tagged x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
+    $logDebug $ "Finished writing " <> fpt
+
+-- | Read from the given file. If the read fails, run the given action and
+-- write that back to the file. Always starts the file off with the
+-- version tag.
+taggedDecodeOrLoad :: (Store a, HasTypeHash a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
+                   => Path Abs File
+                   -> m a
+                   -> m a
+taggedDecodeOrLoad fp mx = do
+    let fpt = T.pack (toFilePath fp)
+    $logDebug $ "Trying to decode " <> fpt
+    mres <- decodeFileMaybe fp
+    case mres of
+        Nothing -> do
+            $logDebug $ "Failure decoding " <> fpt
+            x <- mx
+            taggedEncodeFile fp x
+            return x
+        Just (Tagged x) -> do
+            $logDebug $ "Success decoding " <> fpt
+            return x
+
+decodeFileMaybe :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
+                => Path loc File
+                -> m (Maybe a)
+decodeFileMaybe fp = do
+    mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do
+        $logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err))
+        return Nothing
+    case mbs of
+        Nothing -> return Nothing
+        Just bs -> do
+            liftIO (Just <$> decodeIO bs) `catch` \(err :: PeekException) -> do
+                 let fpt = T.pack (toFilePath fp)
+                 $logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)")
+                 -- liftIO $ BS.appendFile "decode-error-log" $ encodeUtf8 fpt <> " is " <> bs <> "DONE"
+                 -- $logDebug $ "Input: " <> decodeUtf8 (B16.encode bs)
+                 return Nothing

src/Stack/Build.hs

@@ -69,7 +69,7 @@ import           System.Win32.Console (setConsoleCP, setConsoleOutputCP, getCons
 import qualified Control.Monad.Catch as Catch
 #endif
 
-type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLoggerIO m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
 
 -- | Build.
 --