Added support for binary files to to-directory-tree (#2618)

Author: mmhat

dhall/src/Dhall/DirectoryTree.hs

@@ -42,6 +42,7 @@ import System.FilePath           ((</>))
 import System.PosixCompat.Types  (FileMode, GroupID, UserID)
 
 import qualified Control.Exception           as Exception
+import qualified Data.ByteString             as ByteString
 import qualified Data.Foldable               as Foldable
 import qualified Data.Text                   as Text
 import qualified Data.Text.IO                as Text.IO
@@ -279,7 +280,7 @@ getUser (UserName name) =
 -- | Resolve a `Group` to a numerical id.
 getGroup :: Group -> IO GroupID
 getGroup (GroupId gid) = return gid
-getGroup (GroupName name) = 
+getGroup (GroupName name) =
 #ifdef mingw32_HOST_OS
     ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
     where x = "System.Posix.User.getGroupEntryForName: not supported"
@@ -290,21 +291,29 @@ getGroup (GroupName name) =
 -- | Process a `FilesystemEntry`. Writes the content to disk and apply the
 -- metadata to the newly created item.
 processFilesystemEntry :: Bool -> FilePath -> FilesystemEntry -> IO ()
-processFilesystemEntry allowSeparators path (DirectoryEntry entry) = do
-    let path' = path </> entryName entry
-    when (hasMetadata entry && not isMetadataSupported) $
-        Exception.throwIO $ MetadataUnsupportedError path'
-    Directory.createDirectoryIfMissing allowSeparators path'
-    processFilesystemEntryList allowSeparators path' $ entryContent entry
-    -- It is important that we write the metadata after we wrote the content of
-    -- the directories/files below this directory as we might lock ourself out
-    -- by changing ownership or permissions.
-    applyMetadata entry path'
-processFilesystemEntry _ path (FileEntry entry) = do
+processFilesystemEntry allowSeparators path (DirectoryEntry entry) =
+    processEntryWith path entry $ \path' content -> do
+        Directory.createDirectoryIfMissing allowSeparators path'
+        processFilesystemEntryList allowSeparators path' content
+processFilesystemEntry allowSeparators path (FileEntry entry) = do
+    Util.printWarning "`file` is deprecated and will be removed eventually. Please use `text-file` instead."
+    processFilesystemEntry allowSeparators path (TextFileEntry entry)
+processFilesystemEntry _ path (BinaryFileEntry entry) =
+    processEntryWith path entry ByteString.writeFile
+processFilesystemEntry _ path (TextFileEntry entry) =
+    processEntryWith path entry  Text.IO.writeFile
+
+-- | A helper function used by 'processFilesystemEntry'.
+processEntryWith
+    :: FilePath
+    -> Entry a
+    -> (FilePath -> a -> IO ())
+    -> IO ()
+processEntryWith path entry f = do
     let path' = path </> entryName entry
     when (hasMetadata entry && not isMetadataSupported) $
-        Exception.throwIO $ MetadataUnsupportedError path'
-    Text.IO.writeFile path' $ entryContent entry
+        Exception.throwIO (MetadataUnsupportedError path')
+    f path' (entryContent entry)
     -- It is important that we write the metadata after we wrote the content of
     -- the file as we might lock ourself out by changing ownership or
     -- permissions.

dhall/src/Dhall/DirectoryTree/Types.hs

@@ -27,6 +27,7 @@ module Dhall.DirectoryTree.Types
     , isMetadataSupported
     ) where
 
+import Data.ByteString          (ByteString)
 import Data.Functor.Identity    (Identity (..))
 import Data.Sequence            (Seq)
 import Data.Text                (Text)
@@ -72,6 +73,8 @@ type FileEntry = Entry Text
 data FilesystemEntry
     = DirectoryEntry (Entry (Seq FilesystemEntry))
     | FileEntry (Entry Text)
+    | BinaryFileEntry (Entry ByteString)
+    | TextFileEntry (Entry Text)
     deriving (Eq, Generic, Ord, Show)
 
 instance FromDhall FilesystemEntry where
@@ -82,6 +85,10 @@ instance FromDhall FilesystemEntry where
                 DirectoryEntry <$> extract (autoWith normalizer) entry
             Make "file" entry ->
                 FileEntry <$> extract (autoWith normalizer) entry
+            Make "binary-file" entry ->
+                BinaryFileEntry <$> extract (autoWith normalizer) entry
+            Make "text-file" entry ->
+                TextFileEntry <$> extract (autoWith normalizer) entry
             expr -> Decode.typeError (expected (Decode.autoWith normalizer :: Decoder FilesystemEntry)) expr
         }
 

dhall/src/Dhall/Import.hs

@@ -172,6 +172,7 @@ import Data.Text                  (Text)
 import Data.Typeable              (Typeable)
 import Data.Void                  (Void, absurd)
 import Dhall.TypeCheck            (TypeError)
+import Dhall.Util                 (printWarning)
 
 import Dhall.Syntax
     ( Chunks (..)
@@ -1280,15 +1281,6 @@ loadWithManager newManager =
         (makeEmptyStatus newManager defaultOriginHeaders ".")
         UseSemanticCache
 
-printWarning :: (MonadIO m) => String -> m ()
-printWarning message = do
-    let warning =
-                "\n"
-            <> "\ESC[1;33mWarning\ESC[0m: "
-            <> message
-
-    liftIO $ System.IO.hPutStrLn System.IO.stderr warning
-
 -- | Resolve all imports within an expression, importing relative to the given
 -- directory.
 loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)

dhall/src/Dhall/Util.hs

@@ -9,6 +9,8 @@ module Dhall.Util
     , snipDoc
     , insert
     , _ERROR
+    , _WARNING
+    , printWarning
     , Censor(..)
     , Input(..)
     , Transitivity(..)
@@ -111,6 +113,21 @@ insert expression =
 _ERROR :: IsString string => string
 _ERROR = "\ESC[1;31mError\ESC[0m"
 
+-- | Prefix used for error messages
+_WARNING :: IsString string => string
+_WARNING = "\ESC[1;33mWarning\ESC[0m"
+
+-- | Output a warning message on stderr.
+printWarning :: (MonadIO m) => String -> m ()
+printWarning message = do
+    let warning =
+                "\n"
+            <> _WARNING
+            <> ": "
+            <> message
+
+    liftIO $ IO.hPutStrLn IO.stderr warning
+
 get
     :: (String -> Text -> Either ParseError a)
     -> Censor