-- ----------------------------------------------------------------------------- -- 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 Data.Maybe.HT (toMaybe, ) import Data.Maybe (fromMaybe, ) import Data.Tuple.HT (mapSnd, ) import Data.List (intersperse, ) import Data.List.HT (switchL, switchR, maybePrefixOf, dropWhileRev, takeWhileRev, 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 s = s hPutStrCrLf :: IO.Handle -> String -> IO () hPutStrCrLf h s = IO.hPutStr h s >> IO.hPutChar h '\r' >> IO.hPutChar h '\n' die :: String -> IO () die err = do IO.hPutStrLn IO.stderr err exitFailure ----------------------------------------------------------------------------- -- String utils readM :: (Read a, Monad m) => String -> m a readM s = readSM reads s readSM :: Monad m => ReadS a -> String -> m a readSM f s = case f s of [] -> fail $ "No parse of " ++ show s [(x,[])] -> return x [(_,_)] -> fail $ "Junk at end of " ++ show s _ -> fail $ "Ambiguous parse of " ++ show s ----------------------------------------------------------------------------- -- List utils -- Split a list at some delimiter. splitBy :: (a -> Bool) -> [a] -> [[a]] splitBy f = let recourse = uncurry (:) . mapSnd (switchL [] (const recourse)) . break f in recourse -- now also known as intercalate glue :: [a] -> [[a]] -> [a] glue g = concat . intersperse g splits :: [a] -> [([a],[a])] splits xs = zip (inits xs) (tails xs) dropPrefix :: Eq a => [a] -> [a] -> [a] dropPrefix xs pref = fromMaybe xs $ maybePrefixOf pref xs dropSuffix :: Eq a => [a] -> [a] -> [a] dropSuffix xs suf = reverse (reverse xs `dropPrefix` reverse suf) ----------------------------------------------------------------------------- -- File path utils splitPath :: FilePath -> [String] splitPath = splitBy (=='/') joinPath :: [String] -> FilePath joinPath = glue "/" -- Get the directory component of a path -- FIXME: is this good enough? dirname :: FilePath -> FilePath dirname = dropWhileRev (/= '/') -- Get the filename component of a path -- FIXME: probably System.FilePath should be used here. basename :: FilePath -> FilePath basename = takeWhileRev (/= '/') hasTrailingSlash :: FilePath -> Bool hasTrailingSlash = switchR False (\_ -> ('/'==)) ----------------------------------------------------------------------------- -- Time utils formatTimeSensibly :: CalendarTime -> String formatTimeSensibly time = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" time epochTimeToClockTime :: EpochTime -> ClockTime epochTimeToClockTime epoch_time = TOD (numToInteger epoch_time) 0 where numToInteger = numerator . toRational ----------------------------------------------------------------------------- -- concurrency utilities -- block forever wait :: IO a wait = newEmptyMVar >>= takeMVar ----------------------------------------------------------------------------- -- networking utils accept :: Socket -- Listening Socket -> IO (IO.Handle,SockAddr) -- StdIO IO.Handle for read/write accept sock = do (sock', addr) <- Socket.accept sock hndle <- socketToHandle sock' IO.ReadWriteMode return (hndle,addr) ----------------------------------------------------------------------------- -- file utils statFile :: String -> MaybeT IO FileStatus statFile = stat_ getFileStatus statSymLink :: String -> MaybeT IO FileStatus statSymLink = stat_ getSymbolicLinkStatus stat_ :: (FilePath -> IO FileStatus) -> String -> MaybeT IO FileStatus stat_ f filename = MaybeT $ do maybe_stat <- try (f filename) case maybe_stat of Left e -> do errno <- getErrno if errno == eNOENT || errno == eNOTDIR then return Nothing else ioError e Right stat -> return $ Just stat isSymLink :: FilePath -> IO Bool isSymLink = liftM (maybe False isSymbolicLink) . runMaybeT . statSymLink isPrefix :: FilePath -> FilePath -> Bool isPrefix root absolute = FilePath.makeRelative root absolute /= 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 path = do absolute <- Dir.canonicalizePath path return $ if FilePath.hasTrailingPathSeparator path && not (FilePath.hasTrailingPathSeparator absolute) then FilePath.addTrailingPathSeparator absolute else absolute {- | This function should prevent fetching files from outside the document directory using '..' in paths. -} localPath :: FilePath -> String -> IO (Maybe FilePath) localPath root urlPath = case urlPath of '/' : _ -> catchSomeIOErrors isDoesNotExistError (do absolute <- canonicalizePath (root ++ urlPath) return $ toMaybe (isPrefix root absolute) absolute) (const $ return Nothing) _ -> return Nothing ----------------------------------------------------------------------------- -- Exception utils -- | Catch IO Errors for which a given predicate is true. catchSomeIOErrors :: (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a catchSomeIOErrors p = catchJust (\e -> toMaybe (p e) e)