-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright notice,
--    this list of conditions and the following disclaimer.
--
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--
--  * Neither the name of the copyright holder(s) nor the names of
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------

module Network.MoHWS.Utility where

import Control.Exception (try, catchJust, )

import Control.Concurrent (newEmptyMVar, takeMVar, )
import Control.Monad (liftM, )
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, )
import Control.Monad.Fail (MonadFail)

import qualified Data.List.Reverse.StrictElement as Rev
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (fromMaybe, )
import Data.Tuple.HT (mapSnd, )
import Data.List (intersperse, )
import Data.List.HT (switchL, switchR, maybePrefixOf, inits, tails, )
import Data.Ratio (numerator, )
import Foreign.C.Error (getErrno, eNOENT, eNOTDIR, )
import Network.Socket as Socket

import qualified System.FilePath as FilePath
import qualified System.IO as IO
import qualified System.Directory as Dir
import System.IO.Error (isDoesNotExistError, )
import System.Exit (exitFailure, )
import System.Locale (defaultTimeLocale, )
import System.Posix (EpochTime, FileStatus,
          getFileStatus, getSymbolicLinkStatus, isSymbolicLink, )
import System.Time (CalendarTime, formatCalendarTime, ClockTime(TOD), )



-----------------------------------------------------------------------------
-- Utils

-- ToDo: deHex is supposed to remove the '%'-encoding
deHex :: String -> String
deHex :: String -> String
deHex String
s = String
s

hPutStrCrLf :: IO.Handle -> String -> IO ()
hPutStrCrLf :: Handle -> String -> IO ()
hPutStrCrLf Handle
h String
s = Handle -> String -> IO ()
IO.hPutStr Handle
h String
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Char -> IO ()
IO.hPutChar Handle
h Char
'\r' IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Char -> IO ()
IO.hPutChar Handle
h Char
'\n'

die :: String -> IO ()
die :: String -> IO ()
die String
err = do Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr String
err
             IO ()
forall a. IO a
exitFailure

-----------------------------------------------------------------------------
-- String utils

readM :: (Read a, MonadFail m) => String -> m a
readM :: String -> m a
readM String
s = ReadS a -> String -> m a
forall (m :: * -> *) a. MonadFail m => ReadS a -> String -> m a
readSM ReadS a
forall a. Read a => ReadS a
reads String
s

readSM :: (MonadFail m) => ReadS a -> String -> m a
readSM :: ReadS a -> String -> m a
readSM ReadS a
f String
s =
   case ReadS a
f String
s of
      [] -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"No parse of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
      [(a
x,[])] -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
      [(a
_,String
_)]  -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Junk at end of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
      [(a, String)]
_  -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous parse of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s


-----------------------------------------------------------------------------
-- List utils

-- Split a list at some delimiter.
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy a -> Bool
f =
   let recourse :: [a] -> [[a]]
recourse =
          ([a] -> [[a]] -> [[a]]) -> ([a], [[a]]) -> [[a]]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) (([a], [[a]]) -> [[a]]) -> ([a] -> ([a], [[a]])) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ([a] -> [[a]]) -> ([a], [a]) -> ([a], [[a]])
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ([[a]] -> (a -> [a] -> [[a]]) -> [a] -> [[a]]
forall b a. b -> (a -> [a] -> b) -> [a] -> b
switchL [] (([a] -> [[a]]) -> a -> [a] -> [[a]]
forall a b. a -> b -> a
const [a] -> [[a]]
recourse)) (([a], [a]) -> ([a], [[a]]))
-> ([a] -> ([a], [a])) -> [a] -> ([a], [[a]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
f
   in  [a] -> [[a]]
recourse

-- now also known as intercalate
glue :: [a] -> [[a]] -> [a]
glue :: [a] -> [[a]] -> [a]
glue [a]
g = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([[a]] -> [[a]]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
intersperse [a]
g

splits :: [a] -> [([a],[a])]
splits :: [a] -> [([a], [a])]
splits [a]
xs = [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs)

dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix :: [a] -> [a] -> [a]
dropPrefix [a]
xs [a]
pref =
   [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [a]
xs (Maybe [a] -> [a]) -> Maybe [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
maybePrefixOf [a]
pref [a]
xs

dropSuffix :: Eq a => [a] -> [a] -> [a]
dropSuffix :: [a] -> [a] -> [a]
dropSuffix [a]
xs [a]
suf = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`dropPrefix` [a] -> [a]
forall a. [a] -> [a]
reverse [a]
suf)

-----------------------------------------------------------------------------
-- File path utils

splitPath :: FilePath -> [String]
splitPath :: String -> [String]
splitPath = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/')

joinPath :: [String] -> FilePath
joinPath :: [String] -> String
joinPath = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
glue String
"/"

-- Get the directory component of a path
-- FIXME: is this good enough?
dirname :: FilePath -> FilePath
dirname :: String -> String
dirname = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
Rev.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/')

-- Get the filename component of a path
-- FIXME: probably System.FilePath should be used here.
basename :: FilePath -> FilePath
basename :: String -> String
basename = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
Rev.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/')

hasTrailingSlash :: FilePath -> Bool
hasTrailingSlash :: String -> Bool
hasTrailingSlash =
   Bool -> (String -> Char -> Bool) -> String -> Bool
forall b a. b -> ([a] -> a -> b) -> [a] -> b
switchR Bool
False (\String
_ -> (Char
'/'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==))


-----------------------------------------------------------------------------
-- Time utils

formatTimeSensibly :: CalendarTime -> String
formatTimeSensibly :: CalendarTime -> String
formatTimeSensibly CalendarTime
time
   = TimeLocale -> String -> CalendarTime -> String
formatCalendarTime TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %H:%M:%S GMT" CalendarTime
time

epochTimeToClockTime :: EpochTime -> ClockTime
epochTimeToClockTime :: EpochTime -> ClockTime
epochTimeToClockTime EpochTime
epoch_time = Integer -> Integer -> ClockTime
TOD (EpochTime -> Integer
numToInteger EpochTime
epoch_time) Integer
0
  where numToInteger :: EpochTime -> Integer
numToInteger = Ratio Integer -> Integer
forall a. Ratio a -> a
numerator (Ratio Integer -> Integer)
-> (EpochTime -> Ratio Integer) -> EpochTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochTime -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational

-----------------------------------------------------------------------------
-- concurrency utilities

-- block forever
wait :: IO a
wait :: IO a
wait = IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar IO (MVar a) -> (MVar a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar a -> IO a
forall a. MVar a -> IO a
takeMVar

-----------------------------------------------------------------------------
-- networking utils

accept :: Socket                -- Listening Socket
       -> IO (IO.Handle,SockAddr)  -- StdIO IO.Handle for read/write
accept :: Socket -> IO (Handle, SockAddr)
accept Socket
sock = do
 (Socket
sock', SockAddr
addr) <- Socket -> IO (Socket, SockAddr)
Socket.accept Socket
sock
 Handle
hndle <- Socket -> IOMode -> IO Handle
socketToHandle Socket
sock' IOMode
IO.ReadWriteMode
 (Handle, SockAddr) -> IO (Handle, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hndle,SockAddr
addr)

-----------------------------------------------------------------------------
-- file utils

statFile :: String -> MaybeT IO FileStatus
statFile :: String -> MaybeT IO FileStatus
statFile = (String -> IO FileStatus) -> String -> MaybeT IO FileStatus
stat_ String -> IO FileStatus
getFileStatus

statSymLink :: String -> MaybeT IO FileStatus
statSymLink :: String -> MaybeT IO FileStatus
statSymLink = (String -> IO FileStatus) -> String -> MaybeT IO FileStatus
stat_ String -> IO FileStatus
getSymbolicLinkStatus

stat_ :: (FilePath -> IO FileStatus) -> String -> MaybeT IO FileStatus
stat_ :: (String -> IO FileStatus) -> String -> MaybeT IO FileStatus
stat_ String -> IO FileStatus
f String
filename = IO (Maybe FileStatus) -> MaybeT IO FileStatus
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FileStatus) -> MaybeT IO FileStatus)
-> IO (Maybe FileStatus) -> MaybeT IO FileStatus
forall a b. (a -> b) -> a -> b
$ do
  Either IOError FileStatus
maybe_stat <- IO FileStatus -> IO (Either IOError FileStatus)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO FileStatus
f String
filename)
  case Either IOError FileStatus
maybe_stat of
       Left IOError
e -> do
          Errno
errno <- IO Errno
getErrno
          if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eNOENT Bool -> Bool -> Bool
|| Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eNOTDIR
             then Maybe FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FileStatus
forall a. Maybe a
Nothing
             else IOError -> IO (Maybe FileStatus)
forall a. IOError -> IO a
ioError IOError
e
       Right FileStatus
stat ->
          Maybe FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FileStatus -> IO (Maybe FileStatus))
-> Maybe FileStatus -> IO (Maybe FileStatus)
forall a b. (a -> b) -> a -> b
$ FileStatus -> Maybe FileStatus
forall a. a -> Maybe a
Just FileStatus
stat

isSymLink :: FilePath -> IO Bool
isSymLink :: String -> IO Bool
isSymLink = (Maybe FileStatus -> Bool) -> IO (Maybe FileStatus) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Bool -> (FileStatus -> Bool) -> Maybe FileStatus -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FileStatus -> Bool
isSymbolicLink) (IO (Maybe FileStatus) -> IO Bool)
-> (String -> IO (Maybe FileStatus)) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT IO FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO FileStatus -> IO (Maybe FileStatus))
-> (String -> MaybeT IO FileStatus)
-> String
-> IO (Maybe FileStatus)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MaybeT IO FileStatus
statSymLink

isPrefix :: FilePath -> FilePath -> Bool
isPrefix :: String -> String -> Bool
isPrefix String
root String
absolute = String -> String -> String
FilePath.makeRelative String
root String
absolute String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
absolute

{- |
It is important to maintain a trailing slash,
otherwise, say, the URL "http://domain.de/"
will be translated to "/srv/www/",
then canonicalized to "/srv/www"
and then we will no longer be able to resolve this to "/srv/www/index.html".
-}
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath :: String -> IO String
canonicalizePath String
path = do
   String
absolute <- String -> IO String
Dir.canonicalizePath String
path
   String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
      if String -> Bool
FilePath.hasTrailingPathSeparator String
path Bool -> Bool -> Bool
&&
         Bool -> Bool
not (String -> Bool
FilePath.hasTrailingPathSeparator String
absolute)
        then String -> String
FilePath.addTrailingPathSeparator String
absolute
        else String
absolute

{- |
This function should prevent fetching files
from outside the document directory using '..' in paths.
-}
localPath :: FilePath -> String -> IO (Maybe FilePath)
localPath :: String -> String -> IO (Maybe String)
localPath String
root String
urlPath =
   case String
urlPath of
      Char
'/' : String
_ ->
         (IOError -> Bool)
-> IO (Maybe String)
-> (IOError -> IO (Maybe String))
-> IO (Maybe String)
forall a. (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a
catchSomeIOErrors IOError -> Bool
isDoesNotExistError
            (do
               String
absolute <- String -> IO String
canonicalizePath (String
root String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
urlPath)
               Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Maybe String
forall a. Bool -> a -> Maybe a
toMaybe (String -> String -> Bool
isPrefix String
root String
absolute) String
absolute)
            (IO (Maybe String) -> IOError -> IO (Maybe String)
forall a b. a -> b -> a
const (IO (Maybe String) -> IOError -> IO (Maybe String))
-> IO (Maybe String) -> IOError -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
      String
_ -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

-----------------------------------------------------------------------------
-- Exception utils

-- | Catch IO Errors for which a given predicate is true.
catchSomeIOErrors :: (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a
catchSomeIOErrors :: (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a
catchSomeIOErrors IOError -> Bool
p =
   (IOError -> Maybe IOError) -> IO a -> (IOError -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (\IOError
e -> Bool -> IOError -> Maybe IOError
forall a. Bool -> a -> Maybe a
toMaybe (IOError -> Bool
p IOError
e) IOError
e)