* Data, Eq, Ord instances for FileError

* Do some parse operations using Text instead of String * IsFileError class for embedding errors
ddssff · Aug 12, 2018 · 768c08d · 768c08d
1 parent 76685dc
commit 768c08d
Show file tree

Hide file tree

Showing 3 changed files with 41 additions and 53 deletions.
diff --git a/Appraisal/FileCache.hs b/Appraisal/FileCache.hs
@@ -17,6 +17,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RankNTypes #-}
@@ -61,11 +62,11 @@ module Appraisal.FileCache
     ) where
 
 import Appraisal.FileCacheT
-  (FileCacheT, FileCacheTop(FileCacheTop), FileError(Command, Description, Failure, FunctionName, IOException),
+  (FileCacheT, FileCacheTop(FileCacheTop), FileError(Command, Description, SomeFileError, FunctionName, IOException),
    HasFileCacheTop(fileCacheTop))
 import Appraisal.Serialize (deriveSerialize)
 import Appraisal.Utils.ErrorWithIO (readCreateProcessWithExitCode')
-import Control.Exception (try)
+import Control.Exception (IOException, try)
 import Control.Lens (makeLenses, over, set, view)
 import Control.Monad ( unless )
 import "mtl" Control.Monad.Except -- (ExceptT(ExceptT), liftEither, MonadError(..), runExceptT, withExceptT)
@@ -83,6 +84,7 @@ import Data.Generics ( Data(..), Typeable )
 import Data.Monoid ( (<>) )
 import Data.SafeCopy (base, deriveSafeCopy)
 import Debug.Show (V(V))
+import Data.Text (pack, unpack)
 import Language.Haskell.TH (ExpQ, Exp, location, pprint, Q)
 import qualified Language.Haskell.TH.Lift as TH (deriveLiftMany, lift)
 import Network.URI ( URI(..), URIAuth(..), parseRelativeReference, parseURI )
@@ -193,7 +195,7 @@ fileFromCmd byteStringInfo toFileExt cmd = do
         do (file, a) <- fileFromBytes byteStringInfo toFileExt bytes
            return $ (set fileSource (Just (ThePath cmd)) file, a)
     ExitFailure _ ->
-        throwError (FunctionName "fileFromCmd" (Command (shell cmd) code))
+        throwError (FunctionName "fileFromCmd" (Command (pack (show (shell cmd))) (pack (show code))))
 
 -- |Retrieve a URI using curl and turn the resulting data into a File.
 fileFromURI ::
@@ -210,7 +212,7 @@ fileFromURI byteStringInfo toFileExt uri =
          ExitSuccess ->
              do (file, bytes') <- fileFromBytes byteStringInfo toFileExt bytes
                 return (set fileSource (Just (TheURI uri)) file, bytes')
-         _ -> throwError (FunctionName "fileFromURI" (Command cmd code))
+         _ -> throwError (FunctionName "fileFromURI" (Command (pack (show cmd)) (pack (show code))))
 
 -- | Build a file from the output of a command.  This uses a temporary
 -- file to store the contents of the command while we checksum it.  This
@@ -230,7 +232,7 @@ fileFromCmdViaTemp ext exe = do
   (code, _out, _err) <- liftIO (readCreateProcessWithExitCode' cmd P.empty)
   case code of
     ExitSuccess -> installFile tmp
-    ExitFailure _ -> throwError (FunctionName "fileFromCmdViaTemp" (Command cmd code))
+    ExitFailure _ -> throwError (FunctionName "fileFromCmdViaTemp" (Command (pack (show cmd)) (pack (show code))))
     where
       installFile :: FilePath -> FileCacheT st FileError m File
       installFile tmp = fileFromPathViaRename ext tmp `catchError` (throwError . FunctionName "fileFromCmdViaTemp" . Description "install failed")
@@ -247,16 +249,16 @@ fileFromPathViaRename ext path = do
   case result of
     Right (ExitSuccess, out, _err) -> do
       let file = File { _fileSource = Just (ThePath path)
-                      , _fileChksum = take 32 out
+                      , _fileChksum = take 32 (unpack out)
                       , _fileMessages = []
                       , _fileExt = ext }
       dest <- fileCachePathIO file
       liftIO $ do
         logM "fileFromPathViaRename" DEBUG ("renameFile " <> path <> " " <> dest)
         renameFile path dest
       return file
-    Right (code, _, _) -> throwError (Command cmd code :: FileError)
-    Left e -> throwError (IOException e)
+    Right (code, _, _) -> throwError (Command (pack (show cmd)) (pack (show code)) :: FileError)
+    Left (e :: IOException) -> throwError (IOException (pack (show e)))
 
 -- | Move a file into the file cache and incorporate it into a File.
 fileFromPathViaCopy ::
@@ -286,7 +288,7 @@ cacheFile file bytes = do
     (\ (_e :: FileError) -> liftIO (writeFileReadable path bytes) >> return file)
     where
       checkBytes loaded = if loaded == bytes
-                          then throwError (FunctionName "cacheFile" (Failure "Checksum error"))
+                          then throwError (FunctionName "cacheFile" (SomeFileError "Checksum error"))
                           else return file
 
 -- | Read and return the contents of the file from the cache as a ByteString.
@@ -299,7 +301,7 @@ loadBytes file =
          False -> do
            let msg = "Checksum mismatch: expected " ++ show (view fileChksum file) ++ ", file contains " ++ show (md5' bytes)
            liftIO (logM "FileCache.hs" ERROR msg)
-           throwError (FunctionName "loadBytes" (Failure msg))
+           throwError (FunctionName "loadBytes" (SomeFileError msg))
 
 instance Pretty File where
     pPrint (File _ cksum _ ext) = text ("File(" <> show (cksum <> ext) <> ")")

diff --git a/Appraisal/FileCacheT.hs b/Appraisal/FileCacheT.hs
@@ -9,6 +9,7 @@
 -- location based on the file's checksum.
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -23,6 +24,7 @@
 
 module Appraisal.FileCacheT
     ( FileError(..)
+    , IsFileError(fromFileError)
     , logFileError
       -- * Monad and Class
     , FileCacheTop(..)
@@ -36,11 +38,7 @@ module Appraisal.FileCacheT
     , mapFileCacheT
     ) where
 
-#if MIN_VERSION_base(4,9,0)
 import Control.Exception as E (ErrorCall(ErrorCallWithLocation))
-#else
-import qualified Control.Exception as E (ErrorCall(ErrorCall))
-#endif
 import Control.Exception (fromException, IOException, SomeException, throw, try)
 import Control.Lens (_2, view)
 import Control.Monad.Except -- (ExceptT(ExceptT), liftEither, MonadError(..), runExceptT, withExceptT)
@@ -52,61 +50,53 @@ import qualified Data.ByteString.Lazy as P
 #else
 import qualified Data.ByteString as P
 #endif
+import Data.Data (Data)
 import Data.String (IsString(fromString))
 import Debug.Show (V(V))
+import Data.Text (pack, Text, unpack)
 import System.Directory (createDirectoryIfMissing)
-import System.Exit ( ExitCode(..) )
 import System.Log.Logger ( logM, Priority(ERROR) )
-import System.Process (CreateProcess)
-#if !MIN_VERSION_process(1,4,3)
-import System.Process.ListLike (showCreateProcessForUser)
-#endif
 
 data FileError
-    = IOException IOException
-    | ErrorCall E.ErrorCall
-    | Command CreateProcess ExitCode
+    = IOException {-IOException-} Text
+    | ErrorCall {-E.ErrorCall-} Text
+    | Command {-CreateProcess ExitCode-} Text Text
     | CommandInput P.ByteString FileError
     | CommandOut P.ByteString FileError
     | CommandErr P.ByteString FileError
     | FunctionName String FileError
     | Description String FileError
-    | Failure String
-    deriving (Show)
+    | SomeFileError String
+    deriving (Data, Eq, Ord, Show)
 
-instance IsString FileError where
-    fromString = Failure
-
-#if !MIN_VERSION_process(1,4,3)
-instance Show CreateProcess where
-  show = showCreateProcessForUser
-#endif
+instance IsString FileError where fromString = SomeFileError
+class IsFileError e where fromFileError :: FileError -> e
+instance IsFileError FileError where fromFileError = id
 
 instance Show (V FileError) where show (V x) = show x
 
 logFileError :: String -> FileError -> IO ()
-logFileError prefix (Description s e) = logM prefix ERROR (" - error description: " ++ s) >> logFileError prefix e
-logFileError prefix (FunctionName n e) = logM prefix ERROR (" - error function " ++ n) >> logFileError prefix e
-logFileError prefix (IOException e) = logM prefix ERROR (" - IO exception: " ++ show e)
-logFileError prefix (Failure s) = logM prefix ERROR (" - failure: " ++ s)
-logFileError prefix (Command cmd code) = logM prefix ERROR (" - shell command failed: " ++ show cmd ++ " -> " ++ show code)
-logFileError prefix (ErrorCall e) = logM prefix ERROR (" - error call: " ++ show e)
-logFileError prefix (CommandInput bs e) = logM prefix ERROR (" - command input: " ++ show (P.take 1000 bs)) >> logFileError prefix e
-logFileError prefix (CommandOut bs e) = logM prefix ERROR (" - command stdout: " ++ show (P.take 1000 bs)) >> logFileError prefix e
-logFileError prefix (CommandErr bs e) = logM prefix ERROR (" - command stderr: " ++ show (P.take 1000 bs)) >> logFileError prefix e
+logFileError prefix (Description s e) = logM prefix ERROR (" - error description: " <> s) >> logFileError prefix e
+logFileError prefix (FunctionName n e) = logM prefix ERROR (" - error function " <> n) >> logFileError prefix e
+logFileError prefix (IOException e) = logM prefix ERROR (" - IO exception: " <> unpack e)
+logFileError prefix (SomeFileError s) = logM prefix ERROR (" - failure: " <> s)
+logFileError prefix (Command cmd code) = logM prefix ERROR (" - shell command failed: " <> show cmd <> " -> " <> show code)
+logFileError prefix (ErrorCall e) = logM prefix ERROR (" - error call: " <> show e)
+logFileError prefix (CommandInput bs e) = logM prefix ERROR (" - command input: " <> show (P.take 1000 bs)) >> logFileError prefix e
+logFileError prefix (CommandOut bs e) = logM prefix ERROR (" - command stdout: " <> show (P.take 1000 bs)) >> logFileError prefix e
+logFileError prefix (CommandErr bs e) = logM prefix ERROR (" - command stderr: " <> show (P.take 1000 bs)) >> logFileError prefix e
 
 newtype FileCacheTop = FileCacheTop {unFileCacheTop :: FilePath} deriving Show
 
 -- | Class of monads with a 'FilePath' value containing the top
--- of a 'FileCache'.
--- paths do not.  So MonadIO is not a superclass here.
+-- of a 'FileCache'.  MonadIO is not a superclass here because
+-- some FileCache operations (e.g. path construction) do not need it.
 class Monad m => HasFileCacheTop m where
     fileCacheTop :: m FileCacheTop
 
--- | This is the class for operations that do require IO.  Almost all
--- operations require IO, but you can build paths into the cache
--- without it.
-newtype FileCacheT st e m a = FileCacheT {unFileCacheT :: ReaderT (st, FilePath) (ExceptT e m) a} deriving (Monad, Applicative, Functor)
+newtype FileCacheT st e m a =
+    FileCacheT {unFileCacheT :: ReaderT (st, FilePath) (ExceptT e m) a}
+    deriving (Monad, Applicative, Functor)
 
 type FileCache st e a = FileCacheT st FileError Identity a
 
@@ -125,18 +115,14 @@ instance MonadIO m => MonadIO (FileCacheT st FileError m) where
       logErrorCall :: IO (Either SomeException a) -> IO (Either SomeException a)
       logErrorCall x =
           x >>= either (\e -> case fromException e :: Maybe E.ErrorCall of
-#if MIN_VERSION_base(4,9,0)
                                 Just (ErrorCallWithLocation msg loc) -> logM "FileCache.hs" ERROR (show loc ++ ": " ++ msg) >> return (Left e)
-#else
-                                Just (E.ErrorCall msg) -> logM "FileCache.hs" ERROR msg >> return (Left e)
-#endif
                                 _ -> return (Left e)) (return . Right)
       toFileError :: SomeException -> FileError
       toFileError e =
           maybe (throw e)
                 id
-                (msum [fmap IOException (fromException e :: Maybe IOException),
-                       fmap Appraisal.FileCacheT.ErrorCall (fromException e :: Maybe E.ErrorCall)])
+                (msum [fmap (IOException . pack . show) (fromException e :: Maybe IOException),
+                       fmap (Appraisal.FileCacheT.ErrorCall . pack . show) (fromException e :: Maybe E.ErrorCall)])
 
 instance (Monad m, MonadReader (st, FilePath) (FileCacheT st FileError m)) => HasFileCacheTop (FileCacheT st FileError m) where
     fileCacheTop = (FileCacheTop . view _2) <$> ask

diff --git a/image-cache.cabal b/image-cache.cabal
@@ -79,7 +79,7 @@ Library
     network-uri,
     parsec,
     pretty >= 1.1.2,
-    process,
+    process >= 1.4.3,
     process-extras >= 0.7,
     pureMD5,
     QuickCheck >= 2,