diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright NoRedInk (c) 2018 + +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 Author name here nor the names of other + 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# hs-rs-notify + +experimental! no docs yet + +Wraps this awesome rust library so you can use it in haskell. https://docs.rs/crate/notify diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,14 @@ +import Notify +import Protolude + +main :: IO () +main = do + watch "/Users/stoeffel/nri/noredink" [".elm"] callback + putText "done" + +callback :: Event -> IO () +callback event = do + putText "Callback" + print event + threadDelay 10000000 + putText "done" diff --git a/hs-rs-notify.cabal b/hs-rs-notify.cabal new file mode 100644 --- /dev/null +++ b/hs-rs-notify.cabal @@ -0,0 +1,57 @@ +name: hs-rs-notify +version: 0.1.0.0 +synopsis: Experimental! Wraps this awesome rust library so you can use it in haskell. https://docs.rs/crate/notify +-- description: +homepage: https://github.com/NoRedInk/hs-rs-notify#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2018 Author name here +category: Web +build-type: Simple +extra-source-files: README.md + , notifier/target/release/libnotifier.a + , notifier/target/release/libnotifier.d + , notifier/target/release/libnotifier.dylib +cabal-version: >=1.10 + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Notify + build-depends: base >= 4.7 && < 5 + , protolude >= 0.1.6 && < 0.2 + , text == 1.2.2.2 + , filepath == 1.4.1.1 + , unix == 2.7.2.1 + , process == 1.4.3.0 + default-language: Haskell2010 + default-extensions: OverloadedStrings, NoImplicitPrelude + +executable hs-rs-notify + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , hs-rs-notify + , protolude >= 0.1.6 && < 0.2 + default-language: Haskell2010 + default-extensions: OverloadedStrings, NoImplicitPrelude + extra-libraries: notifier, pthread + extra-lib-dirs: ./notifier/target/release + +test-suite hs-rs-notify-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hs-rs-notify + , protolude >= 0.1.6 && < 0.2 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings, NoImplicitPrelude + +source-repository head + type: git + location: https://github.com/githubuser/hs-rs-notify diff --git a/notifier/target/release/libnotifier.a b/notifier/target/release/libnotifier.a new file mode 100644 # file too large to diff: notifier/target/release/libnotifier.a diff --git a/notifier/target/release/libnotifier.d b/notifier/target/release/libnotifier.d new file mode 100644 --- /dev/null +++ b/notifier/target/release/libnotifier.d @@ -0,0 +1,1 @@ +/Users/stoeffel/nri/notify/hs-rf-notify/notifier/target/release/libnotifier.dylib: /Users/stoeffel/nri/notify/hs-rf-notify/notifier/src/lib.rs diff --git a/notifier/target/release/libnotifier.dylib b/notifier/target/release/libnotifier.dylib new file mode 100644 Binary files /dev/null and b/notifier/target/release/libnotifier.dylib differ diff --git a/src/Notify.hs b/src/Notify.hs new file mode 100644 --- /dev/null +++ b/src/Notify.hs @@ -0,0 +1,108 @@ +{-| +Module : Notify +Description : Notify's main module + +This is a haddock comment describing your library +For more information on how to write Haddock comments check the user guide: + +-} +module Notify where + +import Control.Concurrent +import Control.Exception (bracket) +import Control.Monad (when) +import Data.Foldable +import Data.Text as T +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Ptr +import Protolude +import System.FilePath +import System.Posix.Process +import System.Posix.Signals +import System.Posix.Types (ProcessID) +import System.Process + +data Event + = NoticeWrite FilePath + | NoticeRemove FilePath + | Create FilePath + | Write FilePath + | Chmod FilePath + | Remove FilePath + | Rename FilePath + FilePath + | Rescan + | Error T.Text + (Maybe FilePath) + | Unknown + deriving (Show) + +foreign import ccall "watch_for_changes" watchForChanges :: + CString -> FunPtr (CString -> CString -> CString -> IO ()) -> IO () + +foreign import ccall "wrapper" mkCallback :: + (CString -> CString -> CString -> IO ()) -> + IO (FunPtr (CString -> CString -> CString -> IO ())) + +watch :: T.Text -> [T.Text] -> (Event -> IO ()) -> IO () +watch path extensions callback = do + mVar <- newMVar Nothing + cb <- mkCallback $ forkCallback mVar callback extensions + pathCStr <- newCString $ T.unpack path + watchForChanges pathCStr cb + +forkCallback :: + MVar (Maybe ProcessID) + -> (Event -> IO ()) + -> [T.Text] + -> CString + -> CString + -> CString + -> IO () +forkCallback mVar cb extensions eventC aC bC = do + eventStr <- T.pack <$> peekCString eventC + a <- T.pack <$> peekCString aC + b <- T.pack <$> peekCString bC + let event = toEvent eventStr a b + when (relevantEvent event extensions) $ do + runningProcess <- takeMVar mVar + traverse_ (signalProcess softwareTermination) runningProcess + traverse_ (getProcessStatus True False) runningProcess -- here be dragons, potentially + processId <- forkProcess (cb event) + putMVar mVar (Just processId) + +toEvent :: T.Text -> T.Text -> T.Text -> Event +toEvent "NoticeWrite" _ b = NoticeWrite (T.unpack b) +toEvent "NoticeRemove" _ b = NoticeRemove (T.unpack b) +toEvent "Create" _ b = Create (T.unpack b) +toEvent "Write" _ b = Write (T.unpack b) +toEvent "Chmod" _ b = Chmod (T.unpack b) +toEvent "Remove" _ b = Remove (T.unpack b) +toEvent "Rename" a b = Rename (T.unpack a) (T.unpack b) +toEvent "Rescan" _ _ = Rescan +toEvent "Error" msg path = + Error + msg + (case path of + "" -> Nothing + _ -> Just (T.unpack path)) +toEvent _ _ _ = Unknown + +relevantEvent :: Event -> [T.Text] -> Bool +relevantEvent event extensions = + case eventForFile event of + Just path -> elem (T.pack (takeExtension path)) extensions + Nothing -> False + +eventForFile :: Event -> Maybe FilePath +eventForFile (NoticeWrite path) = Just path +eventForFile (NoticeRemove path) = Just path +eventForFile (Create path) = Just path +eventForFile (Write path) = Just path +eventForFile (Chmod path) = Just path +eventForFile (Remove path) = Just path +eventForFile (Rename _ path) = Just path +eventForFile Rescan = Nothing +eventForFile (Error _ maybePath) = maybePath +eventForFile Unknown = Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,4 @@ +import Protolude + +main :: IO () +main = putStrLn ("Test suite not yet implemented" :: Text)