Handle non-ASCII filenames correctly on Windows

ChangeLog.md

@@ -1,3 +1,7 @@
+## 0.8.18.2
+
+* Handle non-ASCII filenames correctly on Windows [#91](https://github.com/snoyberg/yaml/pull/91)
+
 ## 0.8.18.1
 
 * Improve prettyPrintParseException when context is empty [#89](https://github.com/snoyberg/yaml/pull/89)

Text/Libyaml.hs

@@ -29,13 +29,15 @@ module Text.Libyaml
 
 import Prelude hiding (pi)
 
+import Data.Bits ((.|.))
 import Foreign.C
 import Foreign.Ptr
 import Foreign.ForeignPtr
 #if MIN_VERSION_base(4,7,0)
 import Foreign.ForeignPtr.Unsafe
 #endif
 import Foreign.Marshal.Alloc
+import qualified System.Posix.Internals as Posix
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
@@ -147,11 +149,10 @@ foreign import ccall unsafe "yaml_parser_set_input_file"
 data FileStruct
 type File = Ptr FileStruct
 
-foreign import ccall unsafe "fopen"
-    c_fopen :: Ptr CChar
-            -> Ptr CChar
-            -> IO File
-
+foreign import ccall unsafe "fdopen"
+    c_fdopen :: CInt
+             -> Ptr CChar
+             -> IO File
 foreign import ccall unsafe "fclose"
     c_fclose :: File
              -> IO ()
@@ -503,6 +504,24 @@ decode bs =
         c_yaml_parser_delete ptr
         free ptr
 
+-- XXX copied from GHC.IO.FD
+std_flags, read_flags, output_flags, write_flags :: CInt
+std_flags    = Posix.o_NOCTTY
+output_flags = std_flags    .|. Posix.o_CREAT
+read_flags   = std_flags    .|. Posix.o_RDONLY
+write_flags  = output_flags .|. Posix.o_WRONLY
+
+-- | Open a C FILE* from a file path, using internal GHC API to work correctly
+-- on all platforms, even on non-ASCII filenames. The opening mode must be
+-- indicated via both 'rawOpenFlags' and 'openMode'.
+openFile :: FilePath -> CInt -> String -> IO File
+openFile file rawOpenFlags openMode = do
+  fd <- liftIO $ Posix.withFilePath file $ \file' ->
+    Posix.c_open file' rawOpenFlags 0o666
+  if fd /= (-1)
+    then withCString openMode $ \openMode' -> c_fdopen fd openMode'
+    else return nullPtr
+
 decodeFile :: MonadResource m => FilePath
 #if MIN_VERSION_conduit(1, 0, 0)
            -> Producer m Event
@@ -521,12 +540,9 @@ decodeFile file =
                 free ptr
                 throwIO $ YamlException "Yaml out of memory"
             else do
-                file' <- liftIO
-                        $ withCString file $ \file' -> withCString "r" $ \r' ->
-                                c_fopen file' r'
+                file' <- openFile file read_flags "r"
                 if file' == nullPtr
                     then do
-                        c_fclose_helper file'
                         c_yaml_parser_delete ptr
                         free ptr
                         throwIO $ YamlException
@@ -599,9 +615,7 @@ encodeFile filePath =
     bracketP getFile c_fclose $ \file -> runEmitter (alloc file) (\u _ -> return u)
   where
     getFile = do
-        file <- withCString filePath $
-                    \filePath' -> withCString "w" $
-                    \w' -> c_fopen filePath' w'
+        file <- openFile filePath write_flags "w"
         if file == nullPtr
             then throwIO $ YamlException $ "could not open file for write: " ++ filePath
             else return file

examples/Config.hs

@@ -9,6 +9,7 @@ import Data.Yaml (FromJSON(..), (.:))
 import Text.RawString.QQ
 import Data.ByteString (ByteString)
 import Control.Applicative
+import Prelude -- Ensure Applicative is in scope and we have no warnings, before/after AMP.
 
 configYaml :: ByteString
 configYaml = [r|

test/Data/YamlSpec.hs

@@ -19,6 +19,7 @@ import Control.Monad
 import Control.Exception (try, SomeException)
 import Test.Hspec
 import Data.Either.Compat
+import System.Directory (createDirectory)
 import Test.Mockery.Directory
 
 import qualified Data.Yaml as D
@@ -63,6 +64,7 @@ spec = do
     describe "Data.Yaml" $ do
         it "encode/decode" caseEncodeDecodeData
         it "encode/decode file" caseEncodeDecodeFileData
+        it "encode/decode files with non-ASCII names" caseEncodeDecodeNonAsciiFileData
         it "encode/decode strings" caseEncodeDecodeStrings
         it "decode invalid file" caseDecodeInvalid
         it "processes datatypes" caseDataTypes
@@ -317,6 +319,17 @@ caseEncodeDecodeFileData = withFile "" $ \fp -> do
     out <- D.decodeFile fp
     out @?= Just sample
 
+caseEncodeDecodeNonAsciiFileData :: Assertion
+caseEncodeDecodeNonAsciiFileData = do
+  let mySample = (object ["foo" .= True])
+  inTempDirectory $ do
+    createDirectory "accenté"
+    D.encodeFile "accenté/bar.yaml" mySample
+    out1 <- D.decodeFile "accenté/bar.yaml"
+    out1 @?= Just mySample
+  out2 <- D.decodeFile "test/resources/accenté/foo.yaml"
+  out2 @?= Just mySample
+
 caseEncodeDecodeStrings :: Assertion
 caseEncodeDecodeStrings = do
     let out = D.decode $ D.encode sample

test/resources/accenté/foo.yaml

@@ -0,0 +1 @@
+foo: true

yaml.cabal

@@ -1,5 +1,5 @@
 name:            yaml
-version:         0.8.18.1
+version:         0.8.18.2
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov 
@@ -20,6 +20,7 @@ extra-source-files: c/helper.h
                     test/resources/foo.yaml
                     test/resources/bar.yaml
                     test/resources/baz.yaml
+                    test/resources/accenté/foo.yaml
                     test/resources/loop/foo.yaml
                     test/resources/loop/bar.yaml
                     README.md
@@ -130,6 +131,7 @@ test-suite spec
                    , text
                    , aeson >= 0.7
                    , unordered-containers
+                   , directory
                    , vector
                    , resourcet
                    , aeson-qq