ifc: taint proof of concept

This commit adds the Purebred.Types.IFC module for information flow
control (IFC) types and functions.  We begin with a trivial taint
mechanism.  A single aspect of the implementation - tryRunProcess -
is updated to use it, for demonstration and review purposes.

Part of: #269

purebred.cabal

@@ -78,6 +78,7 @@ library
                      , Storage.ParsedMail
                      , Purebred
   other-modules:       Paths_purebred
+                     , Purebred.Types.IFC
   autogen-modules:     Paths_purebred
   build-depends:       base >= 4.9 && < 5
                      , deepseq >= 1.4.2

src/Purebred/System/Process.hs

@@ -24,17 +24,21 @@ import System.Exit (ExitCode(..))
 import Control.Exception (try, IOException)
 import System.Process.Typed (readProcessStderr, ProcessConfig)
 import qualified Data.ByteString.Lazy as LB
-import qualified Data.ByteString.Lazy.Char8 as L8
 import Control.Lens (set, (&))
 import Data.Semigroup ((<>))
 
+import qualified Data.Text as T
+
 import Error
 import Types
+import Purebred.Types.IFC
 
 
 -- | Handler to handle exit failures and possibly showing an error in the UI.
-handleExitCode :: AppState -> (ExitCode, LB.ByteString) -> AppState
-handleExitCode s (ExitFailure e, stderr) = s & setError (ProcessError (show e <> ": " <> L8.unpack stderr))
+handleExitCode :: AppState -> (ExitCode, Tainted LB.ByteString) -> AppState
+handleExitCode s (ExitFailure e, stderr) =
+  s & setError (ProcessError (
+    show e <> ": " <> untaint (T.unpack . sanitiseText . decodeLenient . LB.toStrict) stderr))
 handleExitCode s (ExitSuccess, _) = s
 
 -- | Handle only IOExceptions, everything else is fair game.
@@ -43,8 +47,10 @@ handleIOException s' ex = pure $ s' & setError (ProcessError (show ex))
 
 -- | Try running a process given by the `FilePath` and catch an IOExceptions.
 -- This is to avoid a crashing process also take down the running Brick program.
-tryRunProcess :: ProcessConfig stdout stderr stdin -> IO (Either IOException (ExitCode, LB.ByteString))
-tryRunProcess = try . readProcessStderr
+tryRunProcess
+  :: ProcessConfig stdout stderr stdin
+  -> IO (Either IOException (ExitCode, Tainted LB.ByteString))
+tryRunProcess = (fmap . fmap . fmap) taint . try . readProcessStderr
 
 setError :: Error -> AppState -> AppState
 setError = set asError . Just

src/Purebred/Types/IFC.hs

@@ -0,0 +1,72 @@
+-- This file is part of purebred
+-- Copyright (C) 2019 Fraser Tweedale
+--
+-- purebred is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+
+Information flow control types and functions.
+
+-}
+module Purebred.Types.IFC
+  (
+    Tainted
+  , taint
+  , untaint
+
+  -- * Sanitisation functions
+  , sanitiseText
+  ) where
+
+import Data.Char (chr, isControl, ord)
+
+import qualified Data.Text as T
+
+-- | A tainted value can only be unwrapped by applying 'untaint'
+-- with a sanitisation function.  This approach is used instead of
+-- type classes because how you untaint a value might depend on how
+-- that value will be used.
+--
+-- You /could/ just use 'untaint id' to get the value out.
+-- But you probably shouldn't.
+--
+newtype Tainted a = Tainted a
+
+-- | Taint a value
+taint :: a -> Tainted a
+taint = Tainted
+
+-- | Untaint a value.
+untaint :: (a -> b) -> Tainted a -> b
+untaint f (Tainted a) = f a
+
+-- | Convert or strip control characters from input.
+--
+-- * Tab (HT) is replaced with 8 spaces.
+-- * Other C0 codes (except CR and LF) and DEL are replaced with
+--   <https://en.wikipedia.org/wiki/Control_Pictures Control Pictures>
+-- * C1 and all other control characters are replaced with
+--   REPLACEMENT CHARACTER U+FFFD
+--
+sanitiseText :: T.Text -> T.Text
+sanitiseText = T.map substControl . T.replace "\t" "        "
+  where
+  substControl c
+    | c == '\n' || c == '\r' = c  -- CR and LF are OK
+    | c <= '\x1f' = chr (0x2400 + ord c)
+    | c == '\DEL' = '\x2421'
+    | isControl c = '\xfffd' -- REPLACEMENT CHARACTER
+    | otherwise = c

src/Storage/ParsedMail.hs

@@ -22,7 +22,7 @@ import Data.MIME
 import Error
 import Storage.Notmuch (mailFilepath)
 import Types (NotmuchMail, decodeLenient)
-import UI.Utils (sanitise)
+import Purebred.Types.IFC (sanitiseText)
 
 parseMail
   :: (MonadError Error m, MonadIO m)
@@ -69,7 +69,7 @@ entityToBytes msg = either err Right (convert msg)
     convert m = view body <$> view transferDecoded m
 
 entityToText :: WireEntity -> T.Text
-entityToText msg = sanitise . either err (view body) $
+entityToText msg = sanitiseText . either err (view body) $
   view transferDecoded msg >>= view charsetDecoded
   where
     err :: EncodingError -> T.Text

src/UI/Utils.hs

@@ -22,13 +22,10 @@ module UI.Utils
   , toggledItems
   , selectedFiles
   , takeFileName
-  , sanitise
   ) where
 
-import Data.Char (chr, isControl, ord)
 import Data.List (union)
 
-import qualified Data.Text as T
 import Data.Text (Text, pack, unpack)
 import qualified System.FilePath as FP (takeFileName)
 import Control.Lens
@@ -73,21 +70,3 @@ instance Titleize Name where
 
 instance Titleize ViewName where
   titleize a = pack $ show a
-
--- | Convert or strip control characters from input.
---
--- * Tab (HT) is replaced with 8 spaces.
--- * Other C0 codes (except CR and LF) and DEL are replaced with
---   <https://en.wikipedia.org/wiki/Control_Pictures Control Pictures>
--- * C1 and all other control characters are replaced with
---   REPLACEMENT CHARACTER U+FFFD
---
-sanitise :: T.Text -> T.Text
-sanitise = T.map substControl . T.replace "\t" "        "
-  where
-  substControl c
-    | c == '\n' || c == '\r' = c  -- CR and LF are OK
-    | c <= '\x1f' = chr (0x2400 + ord c)
-    | c == '\DEL' = '\x2421'
-    | isControl c = '\xfffd' -- REPLACEMENT CHARACTER
-    | otherwise = c