diff --git a/Codec/Image/DevIL/Extras.hsc b/Codec/Image/DevIL/Extras.hsc new file mode 100644 --- /dev/null +++ b/Codec/Image/DevIL/Extras.hsc @@ -0,0 +1,113 @@ +-- vim: syntax=haskell + +module Codec.Image.DevIL.Extras ( + Image (..), + loadImage, + unloadImage +) where + +import Control.Applicative +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.Storable +import Data.Array.Unboxed +import Data.Bits +import Data.Int (Int32) +import Data.Word (Word8, Word32, Word64) +import Debug.Trace +import Foreign.C +import Foreign.C.Types +import Foreign hiding (newArray) +import Control.Monad.Error + +#include "IL/il.h" + +type ILuint = #type ILuint +type ILsizei = #type ILsizei +type ILboolean = #type ILboolean +type ILenum = #type ILenum +type ILint = #type ILint +type ILubyte = #type ILubyte + +il_BGR = (#const IL_BGR) :: ILenum +il_BGRA = (#const IL_BGRA) :: ILenum +il_RGB = (#const IL_RGB) :: ILenum +il_RGBA = (#const IL_RGBA) :: ILenum +il_UNSIGNED_BYTE = (#const IL_UNSIGNED_BYTE) :: ILenum +il_IMAGE_HEIGHT = (#const IL_IMAGE_HEIGHT) :: ILenum +il_IMAGE_WIDTH = (#const IL_IMAGE_WIDTH) :: ILenum +il_IMAGE_BPP = (#const IL_IMAGE_BPP) :: ILenum +il_IMAGE_FORMAT = (#const IL_IMAGE_FORMAT) :: ILenum + +newtype ImageName = ImageName { fromImageName :: ILuint } + +data Image = Image { + imgName :: ImageName, + imgHeight :: Int, + imgWidth :: Int, + imgBpp :: Int, + imgData :: StorableArray (Int,Int,Int) Word8 +} + +foreign import CALLTYPE "ilBindImage" ilBindImageC :: ILuint -> IO () + +ilBindImage :: ImageName -> IO () +ilBindImage (ImageName name) = ilBindImageC name + +foreign import CALLTYPE "ilLoadImage" ilLoadImageC :: CString -> IO ILboolean + +ilLoadImage :: FilePath -> IO Bool +ilLoadImage file = do + (0 /=) <$> withCString file ilLoadImageC + +foreign import CALLTYPE "ilGenImages" ilGenImagesC + :: ILsizei -> Ptr ILuint -> IO () + +ilGenImages :: Int -> IO [ImageName] +ilGenImages num = do + ar <- newArray (0, num-1) 0 + withStorableArray ar $ \p -> do + ilGenImagesC (fromIntegral num) p + map ImageName <$> getElems ar + +foreign import CALLTYPE "ilGetInteger" ilGetIntegerC + :: ILenum -> IO ILint + +foreign import CALLTYPE "ilGetData" ilGetDataC + :: IO (Ptr Word8) + +foreign import CALLTYPE "ilDeleteImages" ilDeleteImagesC + :: ILsizei -> Ptr ILuint -> IO () + +ilDeleteImages :: [ImageName] -> IO () +ilDeleteImages names = do + ar <- newListArray (0, length names-1) (fromImageName <$> names) + withStorableArray ar $ \p -> do + ilDeleteImagesC (fromIntegral $ length names) p + +unloadImage :: Image -> IO () +unloadImage img = ilDeleteImages [imgName img] + +loadImage :: String -> IO (Maybe Image) +loadImage filePath = do + [name] <- ilGenImages 1 + ilBindImage name + ilLoadImage filePath + cols <- fmap fromIntegral $ ilGetIntegerC il_IMAGE_WIDTH + rows <- fmap fromIntegral $ ilGetIntegerC il_IMAGE_HEIGHT + bpp <- fmap fromIntegral $ ilGetIntegerC il_IMAGE_BPP + f <- fmap fromIntegral $ ilGetIntegerC il_IMAGE_FORMAT + if (cols <= 1 || rows <= 1) + then do + ilDeleteImages [name] + return Nothing + else do + let bounds = ((0,0,0), (rows-1, cols-1, bpp-1)) + ptr <- ilGetDataC + fptr <- newForeignPtr_ ptr + dat <- unsafeForeignPtrToStorableArray fptr bounds + return $ Just $ Image { + imgName = name, imgHeight = fromIntegral rows, + imgWidth = fromIntegral cols, imgBpp = fromIntegral bpp, + imgData = dat + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +pvd LICENSE + +Copyright (c) 2010, Rickard Nilsson +All rights reserved. + +Permission to use, copy, modify, and distribute this software in source +or binary form for any purpose with or without fee is hereby granted, +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 its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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/Pvc.hs b/Pvc.hs new file mode 100644 --- /dev/null +++ b/Pvc.hs @@ -0,0 +1,127 @@ +-- vim: syntax=haskell + +module Main ( + main +) where + +import System (getArgs) +import System.Console.GetOpt +import Control.Monad (when) +import qualified Data.Map as Map +import Network.Socket +import Network.BSD +import System.IO + +data Flag = + Playlist String | Port String | Host String | Add | Insert | Replace + deriving (Eq) + +data Command = Command { + cmdStr :: String, + cmdOptions :: [OptDescr Flag], + cmdAction :: [Flag] -> [String] -> IO (), + cmdUsage :: String +} + +main = do + args <- getArgs + when (null args) (usageError Nothing "No command given") + (cmd, flags, files) <- parseOptions (head args) (tail args) + cmd flags files + +printHelp = do + putStrLn "Usage:\n pvc [OPTION...]\n" + putStrLn "Photo Viewer Client - a client for controlling pvd (Photo Viewer Daemon).\n" + putStrLn (usageInfo "Options valid for all commands:" commonOptions) + putStrLn "Available commands:" + putStrLn $ unlines $ map (" "++) (Map.keys commandMap) + +printCmdHelp (Command cn opts _ usage) = do + putStrLn ("Usage:\n pvc "++cn++" "++usage++"\n") + putStrLn (usageInfo "Options valid for all commands:" commonOptions) + putStrLn (usageInfo ("Options valid for command \""++cn++"\":") opts) + +usageError Nothing msg = do + printHelp + fail msg + +usageError (Just cmd) msg = do + printCmdHelp cmd + fail msg + +parseOptions cmd argv = case Map.lookup cmd commandMap of + Nothing -> usageError Nothing $ "Unknown command: "++cmd + Just c -> case getOpt Permute (commonOptions++(cmdOptions c)) argv of + (o,n,[] ) -> return (cmdAction c, o, n) + (_,_,errs) -> usageError (Just c) (concat $ map (filter ('\n' /=)) errs) + +commonOptions = + [ Option ['p'] ["port"] (ReqArg Port "PORT") "photo viewer daemon port" + , Option ['h'] ["host"] (ReqArg Host "HOST") "photo viewer daemon host" + ] + +commands = + [ Command "playlist" playlistOpts playlistAct playlistUsage + , Command "next" [] nextAct nextUsage + , Command "prev" [] prevAct prevUsage + , Command "first" [] firstAct firstUsage + , Command "last" [] lastAct lastUsage + , Command "help" [] helpAct helpUsage + ] + +commandMap = Map.fromList $ map (\c -> (cmdStr c, c)) commands + +sendCmdStr flags cmd = do + addrinfos <- getAddrInfo Nothing (Just host) (Just port) + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Stream defaultProtocol + connect sock (addrAddress serveraddr) + h <- socketToHandle sock WriteMode + hPutStrLn h cmd + hClose h + where + host = last [h | Host h <- Host "127.0.0.1" : flags] + port = last [p | Port p <- Port "4245" : flags] + + +helpAct _ [] = printHelp +helpAct _ (c:[]) = case Map.lookup c commandMap of + Just cmd -> printCmdHelp cmd + Nothing -> printHelp +helpAct _ _ = printCmdHelp (commandMap Map.! "help") + +helpUsage = "\n\n Prints help text for the given command" + +playlistOpts = + [ Option ['l'] ["filelist"] (ReqArg Playlist "PLAYLIST") "playlist file" + , Option ['a'] ["add"] (NoArg Add) "adds the selected files to the end of the current playlist" + , Option ['r'] ["replace"] (NoArg Replace) "replaces the contents of the current playlist with the selected files" + , Option ['i'] ["insert"] (NoArg Insert) "inserts the selected files first in the current playlist" + ] + +playlistAct flags files1 = do + files2 <- readPlaylist flags + sendCmdStr flags $ cmdStr++" "++(unwords $ files1++files2) + where + cmdStr | elem Add flags = "playlist add" + | elem Insert flags = "playlist insert 0" + | otherwise = "playlist replace" + readPlaylist fs = fmap (concat . map words) $ sequence [readFile pl | (Playlist pl) <- fs] + +playlistUsage = "[OPTIONS] [FILES]\n\n Manages the current pvd playlist" + +nextAct flags _ = sendCmdStr flags "next" + +nextUsage = "\n\n Shows the next photo in the playlist" + +prevAct flags _ = sendCmdStr flags "prev" + +prevUsage = "\n\n Shows the previous photo in the playlist" + +firstAct flags _ = sendCmdStr flags "first" + +firstUsage = "\n\n Shows the first photo in the playlist" + +lastAct flags _ = sendCmdStr flags "last" + +lastUsage = "\n\n Shows the last photo in the playlist" diff --git a/Pvd.hs b/Pvd.hs new file mode 100644 --- /dev/null +++ b/Pvd.hs @@ -0,0 +1,143 @@ +-- vim: syntax=haskell + +module Main ( + main +) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Trans +import Data.Foldable (notElem) +import Data.Maybe +import Network.Socket +import Prelude hiding (notElem) +import qualified Codec.Image.DevIL as IL (ilInit) +import qualified Graphics.X11.Xlib as X +import qualified Graphics.X11.Xlib.Extras as X +import System.Exit (exitSuccess) +import System.IO +import System (getArgs) +import System.Console.GetOpt +import XUtils + +data Flag = + Port String | CacheSize Int | Playlist String | Help + deriving (Eq) + +data State = State { + stIdx :: Int, + stPlaylist :: [String], + stDpy :: X.Display, + stWin :: X.Window, + stImgCache :: [(String, XImg)], + stLoadLock :: MVar (), + stImgCacheSize :: Int +} + +imgPath (State {stIdx = idx, stPlaylist = pl}) + | idx >= 0 && idx < length pl = Just (pl !! idx) + | otherwise = Nothing + +main = do + args <- getArgs + (flags, files1) <- parseOptions args + files2 <- readPlaylist flags + let cacheSize = last [c | CacheSize c <- CacheSize 15 : flags] + port = last [p | Port p <- Port "4245" : flags] + IL.ilInit + (dpy,win) <- initX + l <- newMVar () + state <- newMVar $ State { + stIdx = 0, stPlaylist = files1++files2, stDpy = dpy, stWin = win, + stImgCache = [], stLoadLock = l, stImgCacheSize = cacheSize + } + updateCache state + forkIO $ eventLoop state + initSocket port >>= socketLoop state + +readPlaylist fs = fmap (concat . map words) $ sequence [readFile pl | (Playlist pl) <- fs] + +printHelp = sequence_ $ map putStrLn $ + [ "Usage:\n pvd [OPTION...] [FILE...]\n" + , "Photo Viewer Daemon - a daemon for viewing photos.\n" + , (usageInfo "Available options:" options) + ] + +options = + [ Option ['h'] ["help"] (NoArg Help) "print this help text" + , Option ['p'] ["port"] (ReqArg Port "PORT") "photo viewer daemon port" + , Option ['c'] ["cache"] (ReqArg (CacheSize . read) "SIZE") "photo cache size" + , Option ['l'] ["playlist"] (ReqArg Playlist "PLAYLIST") "playlist file" + ] + +parseOptions argv = case getOpt Permute options argv of + (o,n,[] ) -> if elem Help o then printHelp >> exitSuccess else return (o, n) + (_,_,errs) -> printHelp >> fail (concat $ map (filter ('\n' /=)) errs) + +initSocket port = withSocketsDo $ do + addrinfos <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing (Just port) + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Stream defaultProtocol + bindSocket sock (addrAddress serveraddr) + listen sock 5 + return sock + +socketLoop state sock = do + (connsock, clientaddr) <- accept sock + forkIO $ processMessages connsock clientaddr + socketLoop state sock + where + processMessages connsock clientaddr = do + connhdl <- socketToHandle connsock ReadMode + hSetBuffering connhdl LineBuffering + messages <- hGetContents connhdl + mapM_ runParseCmd (lines messages) + hClose connhdl + runParseCmd c = do + (redraw,dpy,win) <- modifyMVar state $ \s -> do + let s' = parseCmd c s + return (s', (imgPath s' /= imgPath s, stDpy s', stWin s')) + when redraw $ sendExposeEvent dpy win >> updateCache state + +eventLoop state = do + s <- readMVar state + img <- maybe (return Nothing) (getImg state) (imgPath s) + drawImg (stDpy s) (stWin s) img + X.allocaXEvent $ \e -> X.nextEvent (stDpy s) e + eventLoop state + +getImg state p = do + State { stDpy = d, stImgCache = c, stLoadLock = l } <- readMVar state + img <- maybe (withMVar l (\_ -> loadXImg d p)) (return . Just) (lookup p c) + flip (maybe (return Nothing)) img $ \i -> modifyMVar state $ \s -> do + let c' = (p,i) : (take (cacheSize-1) $ filter ((/=) p . fst) (stImgCache s)) + cacheSize = stImgCacheSize s + return (s {stImgCache = c'}, img) + +updateCache st = do + s@(State {stIdx = idx, stPlaylist = pl}) <- readMVar st + let idxs = take 5 [max 0 (idx-2) .. length pl - 1] + forkIO $ sequence_ $ map (getImg st . (pl !!)) idxs + return () + +parseCmd :: String -> State -> State +parseCmd cmd s@(State {stIdx = idx, stPlaylist = pl}) = case words cmd of + ["next"] -> gotoIdx s (idx+1) + ["prev"] -> gotoIdx s (idx-1) + ["first"] -> gotoIdx s 0 + ["last"] -> gotoIdx s (length pl - 1) + "playlist":"add":imgs -> s { stPlaylist = pl++imgs } + "playlist":"replace":imgs -> + s { stIdx = 0, stPlaylist = imgs, stImgCache = [] } + "playlist":"insert":"0":imgs -> + s { stIdx = idx + (length imgs), stPlaylist = imgs++pl } + _ -> s + +gotoIdx s@(State {stPlaylist = pl}) n + | n >= 0 && n < (length pl) = s { stIdx = n } + | otherwise = s diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +Installation + + cabal install + + +Usage + + pvd --help + + pvc help 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/pvd.cabal b/pvd.cabal new file mode 100644 --- /dev/null +++ b/pvd.cabal @@ -0,0 +1,34 @@ +Name: pvd +Version: 1.0.0 + +Synopsis: A photo viewer daemon application with remote controlling abilities. + +Description: pvd, Photo Viewer Daemon, is an image viewer application that displays a fullscreen X11 window and listens for remote commands over TCP. The project also includes pvc, a simple command line client application you can use to control pvd. pvc has commands for setting the current photo playlist, jumping between photos, etc. pvd implements caching in the background which makes it possible to quickly switch between photos even if the files are fetched over network or if pvd runs on a slow computer. pvd uses the DevIL image library for loading photo files, which supports a large number of image formats. + +Homepage: http://code.haskell.org/pvd +License: BSD3 +License-file: LICENSE +Author: Rickard Nilsson +Maintainer: rickard.nilsson@telia.com +Copyright: (c) 2010, Rickard Nilsson +Category: Image Viewer +Build-type: Simple +Extra-source-files: README +Cabal-version: >=1.2 + +Executable pvd + Main-Is: Pvd.hs + Build-Depends: base >= 4 && < 5, array, X11, Codec-Image-DevIL, network, mtl + Other-Modules: Codec.Image.DevIL.Extras + Build-tools: hsc2hs + Extensions: ForeignFunctionInterface, CPP + Ghc-Options: -threaded + Extra-Libraries: IL, pthread + if os(windows) + CPP-Options: -DCALLTYPE=stdcall + else + CPP-Options: -DCALLTYPE=ccall + +Executable pvc + Main-Is: Pvc.hs + Build-Depends: base >= 4 && < 5, haskell98, network, containers