/Utils.hs
Haskell | 75 lines | 46 code | 10 blank | 19 comment | 6 complexity | 728658e9ed63a94380bbaf14d91bfa53 MD5 | raw file
Possible License(s): GPL-2.0
1{- 2Copyright (C) 2005 John Goerzen <jgoerzen@complete.org> 3 4This program is free software; you can redistribute it and/or modify 5it under the terms of the GNU General Public License as published by 6the Free Software Foundation; either version 2 of the License, or 7(at your option) any later version. 8 9This program is distributed in the hope that it will be useful, 10but WITHOUT ANY WARRANTY; without even the implied warranty of 11MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12GNU General Public License for more details. 13 14You should have received a copy of the GNU General Public License 15along with this program; if not, write to the Free Software 16Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 17-} 18 19module Utils where 20 21import Types 22import Config 23import MissingH.Maybe 24import MissingH.Path 25import Control.Concurrent 26import Control.Exception 27import System.IO 28--import Foreign.C.String 29import Data.List 30 31 32getFSPath :: GAddress -> FilePath 33getFSPath ga = 34 forceMaybeMsg ("getFSPath1 " ++ show ga) . secureAbsNormPath (baseDir ++ "/gopher") $ base 35 where base = (host ga) ++ "/" ++ (show $ port ga) ++ "/" ++ 36 (path ga) ++ case (dtype ga) of 37 '1' -> "/.gophermap" 38 _ -> "" 39 40newLock :: IO Lock 41newLock = newEmptyMVar 42 43acquire :: Lock -> IO () 44acquire l = 45 do t <- myThreadId 46 putMVar l t 47 48release :: Lock -> IO () 49release l = 50 do t <- myThreadId 51 r <- tryTakeMVar l 52 case r of 53 Nothing -> do msg $ "Warning: released lock which was unheld." 54 Just x -> if x == t 55 then return () 56 else fail $ "Thread " ++ (show t) ++ 57 " released lock held by thread " ++ 58 (show x) 59 60withLock :: Lock -> (IO a) -> IO a 61withLock l action = bracket_ (acquire l) (release l) action 62 63msg :: String -> IO () 64msg l = 65 do t <- myThreadId 66 let disp = (show t) ++ ": " ++ l ++ "\n" 67 putStr disp 68 hFlush stdout 69 --withCStringLen disp (\(c, len) -> hPutBuf stdout c len >> hFlush stdout) 70 71ce :: String -> String 72ce i = 73 '\'' : 74 (concat $ map (\c -> if c == '\'' then "''" else [c]) i) 75 ++ "'"