Importing initial code.

LICENSE

@@ -0,0 +1,28 @@
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. 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.
+
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

System/Win32/FileNotify.hsc

@@ -0,0 +1,133 @@
+module System.Win32.FileNotify where
+
+import System.Win32.File
+import System.Win32.Types
+
+import Foreign
+import Foreign.C
+
+import Data.Bits
+
+
+#include <windows.h>
+
+getWatchHandle :: FilePath -> IO HANDLE
+getWatchHandle dir = 
+    createFile dir 
+        fILE_LIST_DIRECTORY -- Access mode 
+        (fILE_SHARE_READ .|. fILE_SHARE_WRITE) -- Share mode
+        Nothing -- security attributes
+        oPEN_EXISTING -- Create mode, we want to look at an existing directory
+        fILE_FLAG_BACKUP_SEMANTICS -- File attribute, nb NOT using OVERLAPPED since we work synchronously
+        Nothing -- No template file
+
+
+readDirectoryChanges :: HANDLE -> Bool -> FileNotificationFlag -> IO [(Action, String)]
+readDirectoryChanges h wst mask = do
+    let maxBuf = 16384
+    allocaBytes maxBuf $ \buffer -> do
+    alloca $ \bret -> do
+        readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret
+        readChanges buffer
+
+data Action = FileAdded | FileRemoved | FileModified | FileRenamedOld | FileRenamedNew
+  deriving (Show, Read, Eq, Ord, Enum)
+
+readChanges :: Ptr FILE_NOTIFY_INFORMATION -> IO [(Action, String)]
+readChanges pfni = do 
+    fni <- peekFNI pfni
+    let entry = (faToAction $ fniAction fni, fniFileName fni)
+        nioff = fromEnum $ fniNextEntryOffset fni
+    entries <- if nioff == 0 then return [] else readChanges $ pfni `plusPtr` nioff
+    return $ entry:entries
+
+faToAction :: FileAction -> Action
+faToAction fa = toEnum $ fromEnum fa - 1
+
+-------------------------------------------------------------------
+-- Low-level stuff that binds to notifications in the Win32 API
+
+-- Defined in System.Win32.File, but with too few cases:
+-- type AccessMode = UINT
+
+#{enum AccessMode,
+ , fILE_LIST_DIRECTORY = FILE_LIST_DIRECTORY
+ }
+-- there are many more cases but I only need this one.
+
+type FileAction = DWORD
+
+#{enum FileAction,
+ , fILE_ACTION_ADDED            = FILE_ACTION_ADDED
+ , fILE_ACTION_REMOVED          = FILE_ACTION_REMOVED
+ , fILE_ACTION_MODIFIED         = FILE_ACTION_MODIFIED
+ , fILE_ACTION_RENAMED_OLD_NAME = FILE_ACTION_RENAMED_OLD_NAME
+ , fILE_ACTION_RENAMED_NEW_NAME = FILE_ACTION_RENAMED_NEW_NAME
+ }
+
+type WCHAR = Word16
+-- This is a bit overkill for now, I'll only use nullFunPtr anyway, 
+-- but who knows, maybe someday I'll want asynchronous callbacks on the OS level.
+type LPOVERLAPPED_COMPLETION_ROUTINE = FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
+
+data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
+    { fniNextEntryOffset, fniAction :: DWORD
+    , fniFileName :: String
+    }
+
+-- instance Storable FILE_NOTIFY_INFORMATION where
+-- ... well, we can't write an instance since the struct is not of fix size,
+-- so we'll have to do it the hard way, and not get anything for free. Sigh.
+
+-- sizeOfFNI :: FILE_NOTIFY_INFORMATION -> Int
+-- sizeOfFNI fni =  (#size FILE_NOTIFY_INFORMATION) + (#size WCHAR) * (length (fniFileName fni) - 1)
+
+peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
+peekFNI buf = do
+    neof <- (#peek FILE_NOTIFY_INFORMATION, NextEntryOffset)        buf
+    acti <- (#peek FILE_NOTIFY_INFORMATION, Action)                 buf
+    fnle <- (#peek FILE_NOTIFY_INFORMATION, FileNameLength)         buf
+    fnam <- peekCWStringLen 
+                (buf `plusPtr` (#offset FILE_NOTIFY_INFORMATION, FileName), -- start of array
+                fromEnum (fnle :: DWORD) `div` 2 ) -- fnle is the length in *bytes*, and a WCHAR is 2 bytes
+    return $ FILE_NOTIFY_INFORMATION neof acti fnam
+
+
+readDirectoryChangesW :: HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag -> LPDWORD -> IO ()
+readDirectoryChangesW h buf bufSize wst f br = 
+  failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize wst f br nullPtr nullFunPtr
+
+{-
+asynchReadDirectoryChangesW :: HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag 
+                                -> LPOVERLAPPED -> IO ()
+asynchReadDirectoryChangesW h buf bufSize wst f over =
+  failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize wst f nullPtr over nullFunPtr
+
+cbReadDirectoryChangesW :: HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag 
+                                -> LPOVERLAPPED -> IO BOOL
+cbReadDirectoryChanges
+-}
+foreign import stdcall safe "windows.h ReadDirectoryChangesW"
+  c_ReadDirectoryChangesW :: HANDLE -> LPVOID -> DWORD -> BOOL -> DWORD 
+                                -> LPDWORD -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL
+
+{-
+type CompletionRoutine :: (DWORD, DWORD, LPOVERLAPPED) -> IO ()
+foreign import ccall "wrapper" 
+    mkCompletionRoutine :: CompletionRoutine -> IO (FunPtr CompletionRoutine)
+
+type LPOVERLAPPED = Ptr OVERLAPPED
+type LPOVERLAPPED_COMPLETION_ROUTINE = FunPtr CompletionRoutine
+
+data OVERLAPPED = OVERLAPPED
+    {
+    }
+
+
+-- In System.Win32.File, but missing a crucial case:
+-- type FileNotificationFlag = DWORD
+-}
+#{enum FileNotificationFlag,
+ , fILE_NOTIFY_CHANGE_CREATION    = FILE_NOTIFY_CHANGE_CREATION
+ , fILE_NOTIFY_CHANGE_LAST_ACCESS = FILE_NOTIFY_CHANGE_LAST_ACCESS
+ }

System/Win32/Notify.hs

@@ -0,0 +1,148 @@
+module System.Win32.Notify (
+      watchDirectory        -- FilePath -> Bool -> [EventVariety] -> IO [Event]
+    , Event(..)
+    , EventVariety(..)
+
+    ) where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Data.Bits
+import Data.List (intersect)
+import Data.Map (Map)
+import System.Directory
+import System.Win32.File
+import System.Win32.FileNotify
+import qualified Data.Map as Map
+
+
+-- import System.IO.Unsafe (unsafeInterleaveIO)
+
+{-
+addDirWatch :: FilePath -> Bool -> [EventVariety] -> (Event -> IO ()) -> IO ()
+addDirWatch dir wst evs cb = trace "addDirWatch" (forkIO loop) >> trace "addDirWatch: forked" (return ())
+  where loop = do
+            trace "addDirWatch: start loop" $ return ()
+            e <- watchDirectory dir wst evs
+            trace "addDirWatch: watchDirectory returned" $ return ()
+            forkIO $ cb e
+            trace "addDirWatch: callback forked" $ return ()
+-}
+
+data EventVariety
+    = Modify
+    | Move
+    | Create
+    | Delete
+  deriving Eq
+
+data Event
+    -- | A file was modified. @Modified isDirectory file@
+    = Modified
+        { isDirectory :: Bool
+        , maybeFilePath :: Maybe FilePath
+        }
+    -- | A file was moved within the directory.
+    | Renamed
+        { isDirectory :: Bool
+        , oldName     :: Maybe FilePath
+        , newName     :: FilePath
+        }
+    -- | A file was created. @Created isDirectory file@
+    | Created
+        { isDirectory :: Bool
+        , filePath :: FilePath
+        }
+    -- | A file was deleted. @Deleted isDirectory file@
+    | Deleted
+        { isDirectory :: Bool
+        , filePath :: FilePath
+        }
+    deriving (Eq, Show)
+
+type Handler = Event -> IO ()
+
+data WatchId = WatchId ThreadId ThreadId
+type WatchMap = Map WatchId Handler
+data WatchManager = WatchManager (MVar WatchMap)
+
+initWatchManager :: IO WatchManager
+initWatchManager = return (newMVar Map.empty :: MVar WatchMap)
+
+killWatchManager :: WatchManager -> IO ()
+killWatchManager (WatchManager watchMap) = do
+  flip mapM_ (Map.elems watchMap) $ killThreads
+  where
+    killThreads (tid1, tid2) = do
+      killThread tid1
+      killThread tid2
+
+varietiesToFnFlags :: [EventVariety] -> FileNotificationFlag
+varietiesToFnFlags = foldl (.|.) 0 . map evToFnFlag'
+    where evToFnFlag' :: EventVariety -> FileNotificationFlag
+          evToFnFlag' ev = case ev of
+                            Modify  -> fILE_NOTIFY_CHANGE_LAST_WRITE
+                            Move    -> fILE_NOTIFY_CHANGE_FILE_NAME .|. fILE_NOTIFY_CHANGE_DIR_NAME
+                            Create  -> fILE_NOTIFY_CHANGE_FILE_NAME .|. fILE_NOTIFY_CHANGE_DIR_NAME
+                            Delete  -> fILE_NOTIFY_CHANGE_FILE_NAME .|. fILE_NOTIFY_CHANGE_DIR_NAME
+
+-- watchDirectoryOnce :: FilePath -> Bool -> [EventVariety] -> IO
+-- watchDirectoryOnce dir wst evs = do
+--         h <- getWatchHandle dir
+--         readDirectoryChanges h wst (evToFnFlag evs) >>= actsToEvent
+
+watchDirectory :: WatchManager -> FilePath -> Bool -> [EventVariety] -> Handler -> IO ()
+watchDirectory (WatchManager watchMap) dir watchSubTree varieties handler = do
+  watchHandle <- getWatchHandle dir
+  chanEvents <- newChan
+  tid1 <- forkIO $ dispatcher chanEvents
+  tid2 <- forkIO $ osEventsReader watchHandle chanEvents
+  modifyMVar_ watchMap $ \m -> return (Map.insert (tid1, tid2) handler watchMap)
+  where
+    dispatcher :: Chan [Event] -> IO ()
+    dispatcher chanEvents = do
+      events <- readChan chanEvents
+      mapM_ maybeHandle events
+      dispatcher chanEvents
+    osEventsReader :: handleType -> Chan [Event] -> IO ()
+    osEventsReader watchHandle chanEvents = do
+      event <- (readDirectoryChanges watchHandle watchSubTree (varietiesToFnFlags varieties) >>= actsToEvent)
+      writeChan chanEvents [event]
+      osEventsReader watchHandle chanEvents
+    maybeHandle :: Handler
+    maybeHandle event =
+      if not (null ((eventToVarieties event) `intersect` varieties)) then handler event else return ()
+    -- maybeHandle event@(Created  _ _) = handleWhen Create varieties handler event
+    -- maybeHandle event@(Deleted  _ _) = if Delete `elem` varieties then handler event else return ()
+    -- maybeHandle event@(Modified _ _) = if Modify `elem` varieties then handler event else return ()
+    -- maybeHandle event@(Renamed  _ _) = if Move   `elem` varieties then handler event else return ()
+    -- handleWhen :: EventVariety -> [EventVariety] -> Handler -> Event -> IO ()
+    -- handleWhen variety varieties handler event = if variety `elem` varieties then handler event else return ()
+
+eventToVarieties :: Event -> [EventVariety]
+eventToVarieties event = case event of
+  Created  _ _   -> [Create]
+  Deleted  _ _   -> [Delete]
+  Modified _ _   -> [Modify]
+  Renamed  _ _ _ -> [Move]
+
+-- watchDirectory :: FilePath -> Bool -> [EventVariety] -> IO [Event]
+-- watchDirectory dir wst evs = do
+--         h <- getWatchHandle dir
+--         loop h
+--     where loop h = do e <- readDirectoryChanges h wst (evToFnFlag evs) >>= actsToEvent
+--                       es <- unsafeInterleaveIO $ loop h
+--                       return $ e:es
+
+actsToEvent :: [(Action, String)] -> IO Event
+actsToEvent [] = error "The impossible happened - there was no event!"
+actsToEvent [(act, fn)] = do
+    isDir <- doesDirectoryExist fn
+    case act of
+        FileModified    -> return $ Modified isDir (Just fn)
+        FileAdded       -> return $ Created isDir fn
+        FileRemoved     -> return $ Deleted isDir fn
+        FileRenamedOld  -> return $ Renamed isDir Nothing fn
+actsToEvent [(FileRenamedOld, fnold),(FileRenamedNew, fnnew)] = do
+    isDir <- doesDirectoryExist fnnew
+    return $ Renamed isDir (Just fnold) fnnew

Win32-notify.cabal

@@ -0,0 +1,18 @@
+name:           Win32-notify
+version:        0.2
+license:        BSD3
+license-file:   LICENSE
+author:         Niklas Broberg
+copyright:      Niklas Broberg, 2008
+maintainer:     Niklas Broberg <[email protected]>
+category:       System
+synopsis:       A binding to part of the Win32 library for file notification
+description:    A binding to part of the Win32 library for file notification
+build-type:     Simple
+build-depends:  base, Win32, directory, containers >= 0.4.0.0
+ghc-options:    -Wall -fno-warn-incomplete-patterns -fno-warn-unused-imports
+extensions:     ForeignFunctionInterface
+
+exposed-modules:        System.Win32.Notify
+other-modules:          System.Win32.FileNotify
+