GetFILE.hs

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.IO.GetFILE
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   The GET method for file protocol

-}

-- ------------------------------------------------------------

module Text.XML.HXT.IO.GetFILE
    ( getStdinCont
    , getCont
    )

where

import qualified Data.ByteString        as B
import qualified Data.ByteString.Char8  as C

import           Network.URI            ( unEscapeString
                                        )

import           System.IO              ( IOMode(..)
                                        , openBinaryFile
                                          -- , getContents  is defined in the prelude
                                        , hGetContents
                                        )

import           System.IO.Error        ( ioeGetErrorString
                                        , try
                                        )

import           System.Directory       ( doesFileExist
                                        , getPermissions
                                        , readable
                                        )
import           Text.XML.HXT.DOM.XmlKeywords

-- ------------------------------------------------------------

getStdinCont            :: Bool -> IO (Either ([(String, String)], String)
                                              String)
getStdinCont strictInput
    = do
      c <- try ( if strictInput
                 then do
                      cb <- B.getContents
                      return  (C.unpack cb)
                 else getContents
               )
      return (either readErr Right c)
    where
    readErr e
        = Left ( [ (transferStatus,  "999")
                 , (transferMessage, msg)
                 ]
               , msg
               )
          where
          msg = "stdin read error: " ++ es
          es  = ioeGetErrorString e

getCont         :: Bool -> String -> IO (Either ([(String, String)], String)
                                                String)
getCont strictInput source
    = do                        -- preliminary
      source'' <- checkFile source'
      case source'' of
           Nothing -> return $ fileErr "file not found"
           Just fn -> do
                      perm <- getPermissions fn
                      if not (readable perm)
                         then return $ fileErr "file not readable"
                         else do
                              c <- try $
                                   if strictInput
                                      then do
                                           cb <- B.readFile fn
                                           return (C.unpack cb)
                                      else do
                                           h <- openBinaryFile fn ReadMode
                                           hGetContents h
                              return (either readErr Right c)
    where
    source' = drivePath $ source
    readErr e
        = fileErr (ioeGetErrorString e)
    fileErr msg0
        = Left ( [ (transferStatus,  "999")
                 , (transferMessage, msg)
                 ]
               , msg
               )
          where
          msg = "file read error: " ++ show msg0 ++ " when accessing " ++ show source'

    -- remove leading / if file starts with windows drive letter, e.g. /c:/windows -> c:/windows
    drivePath ('/' : file@(d : ':' : _more))
        | d `elem` ['A'..'Z'] || d `elem` ['a'..'z']
            = file
    drivePath file
        = file

-- | check whether file exists, if not
-- try to unescape filename and check again
-- return the existing filename

checkFile       :: String -> IO (Maybe String)
checkFile fn
    = do
      exists <- doesFileExist fn
      if exists
         then return (Just fn)
         else do
              exists' <- doesFileExist fn'
              return ( if exists'
                       then Just fn'
                       else Nothing
                     )
    where
    fn' = unEscapeString fn

-- ------------------------------------------------------------