removing unsafePerformIO.

FileCache.hs

@@ -4,14 +4,14 @@ module FileCache (fileCacheInit) where
 
 import Control.Concurrent
 import Control.Exception
+import Control.Exception.IOChoice
 import Control.Monad
 import Data.ByteString (ByteString)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as M
 import Data.IORef
 import Network.HTTP.Date
 import Network.Wai.Application.Classic
-import System.IO.Unsafe
 import System.Posix.Files
 
 data Entry = Negative | Positive FileInfo
@@ -20,40 +20,49 @@ type GetInfo = Path -> IO FileInfo
 
 fileInfo :: IORef Cache -> GetInfo
 fileInfo ref path = do
-  !mx <- atomicModifyIORef ref (lok path)
-  case mx of
-      Nothing -> throwIO (userError "fileInfo")
-      Just x  -> return x
-
-lok :: Path -> Cache -> (Cache, Maybe FileInfo)
-lok path cache = unsafePerformIO $ do
-    let ment = M.lookup bpath cache
-    case ment of
-        Nothing -> handle handler $ do
+    cache <- readIORef ref
+    case M.lookup bpath cache of
+        Just Negative     -> throwIO (userError "fileInfo")
+        Just (Positive x) -> return x
+        Nothing           -> do
             let sfile = pathString path
             fs <- getFileStatus sfile
-            if doesExist fs then pos fs else neg
-        Just Negative     -> return (cache, Nothing)
-        Just (Positive x) -> return (cache, Just x)
+            if not (isDirectory fs) then
+                positive ref fs path ||> negative ref path
+              else
+                negative ref path
+  where
+    bpath = pathByteString path
+
+positive :: IORef Cache -> FileStatus -> GetInfo
+positive ref fs path = do
+    !_ <- atomicModifyIORef ref modify
+    return info
   where
+    info = FileInfo {
+        fileInfoName = path
+        , fileInfoSize = size fs
+        , fileInfoTime = mtime fs
+        }
     size = fromIntegral . fileSize
     mtime = epochTimeToHTTPDate . modificationTime
-    doesExist = not . isDirectory
+    entry = Positive info
     bpath = pathByteString path
-    pos fs = do
-        let info = FileInfo {
-                fileInfoName = path
-              , fileInfoSize = size fs
-              , fileInfoTime = mtime fs
-              }
-            entry = Positive info
-            cache' = M.insert bpath entry cache
-        return (cache', Just info)
-    neg = do
-        let cache' = M.insert bpath Negative cache
-        return (cache', Nothing)
-    handler :: SomeException -> IO (Cache, Maybe FileInfo)
-    handler _ = neg
+    modify cache = (cache', ())
+      where
+        cache' = M.insert bpath entry cache
+
+negative :: IORef Cache -> GetInfo
+negative ref path = do
+    !_ <- atomicModifyIORef ref modify
+    throwIO (userError "fileInfo")
+  where
+    bpath = pathByteString path
+    modify cache = (cache', ())
+      where
+        cache' = M.insert bpath Negative cache
+
+----------------------------------------------------------------
 
 fileCacheInit :: IO GetInfo
 fileCacheInit = do

mighttpd2.cabal

@@ -19,13 +19,16 @@ Executable mighty
   Main-Is:              Mighty.hs
   GHC-Options:          -Wall -fno-warn-unused-do-bind -threaded
   Build-Depends:        base >= 4.0 && < 5
+                      -- should be removed someday
+                      , blaze-html >= 0.5
                       , bytestring
                       , deepseq
                       , directory
                       , filepath
                       , http-conduit
                       , http-date
                       , http-types
+                      , io-choice
                       , network
                       , network-conduit
                       , old-locale
@@ -36,8 +39,6 @@ Executable mighty
                       , unix-bytestring
                       , unordered-containers
                       , wai >= 1.1
-                      -- should be removed someday
-                      , blaze-html >= 0.5
                       , wai-app-file-cgi
                       , wai-logger
                       , wai-logger-prefork