diff --git a/Pvc.hs b/Pvc.hs --- a/Pvc.hs +++ b/Pvc.hs @@ -51,13 +51,13 @@ 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 + 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) + (_,_,errs) -> usageError (Just c) (concatMap (filter ('\n' /=)) errs) commonOptions = - [ Option ['p'] ["port"] (ReqArg Port "PORT") "photo viewer daemon port" - , Option ['h'] ["host"] (ReqArg Host "HOST") "photo viewer daemon host" + [ Option "p" ["port"] (ReqArg Port "PORT") "photo viewer daemon port" + , Option "h" ["host"] (ReqArg Host "HOST") "photo viewer daemon host" ] commands = @@ -93,20 +93,20 @@ 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" + [ 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" + cmdStr | Add `elem` flags = "playlist add" + | Insert `elem` flags = "playlist insert 0" | otherwise = "playlist replace" - readPlaylist fs = fmap (concat . map words) $ sequence [readFile pl | (Playlist pl) <- fs] + readPlaylist fs = fmap (concatMap words) $ sequence [readFile pl | (Playlist pl) <- fs] playlistUsage = "[OPTIONS] [FILES]\n\n Manages the current pvd playlist" diff --git a/Pvd.hs b/Pvd.hs --- a/Pvd.hs +++ b/Pvd.hs @@ -1,19 +1,15 @@ --- 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 Control.Concurrent.STM +import Control.Monad (when) +import Data.Maybe (maybe) +import Data.List +import Data.Ord (comparing) +import Data.Function (on) 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 @@ -23,23 +19,25 @@ import System.Console.GetOpt import XUtils -data Flag = - Port String | CacheSize Int | Playlist String | Help - deriving (Eq) +type Index = TVar Int +type Playlist = TVar [String] +type Cache = TVar [(String, CachedImg)] +data CachedImg = CachedImg XImg | LoadingImg | LoadFailed + data State = State { - stIdx :: Int, - stPlaylist :: [String], + stIdx :: Index, + stPlaylist :: Playlist, stDpy :: X.Display, stWin :: X.Window, - stImgCache :: [(String, XImg)], - stLoadLock :: MVar (), - stImgCacheSize :: Int + stImgCache :: Cache, + stImgCacheSize :: Int, + stSocket :: Socket } -imgPath (State {stIdx = idx, stPlaylist = pl}) - | idx >= 0 && idx < length pl = Just (pl !! idx) - | otherwise = Nothing +data Flag = + Port String | CacheSize Int | Playlist String | Help + deriving (Eq) main = do args <- getArgs @@ -49,33 +47,36 @@ 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 + socket <- initSocket port + cache <- newTVarIO [] + idx <- newTVarIO 0 + playlist <- newTVarIO (files1++files2) + let state = State { + stIdx = idx, stPlaylist = playlist, stDpy = dpy, stWin = win, + stImgCache = cache, stImgCacheSize = cacheSize, stSocket = socket } - updateCache state + forkIO $ cacheLoop state forkIO $ eventLoop state - initSocket port >>= socketLoop state + socketLoop state -readPlaylist fs = fmap (concat . map words) $ sequence [readFile pl | (Playlist pl) <- fs] +readPlaylist fs = fmap (concatMap words) $ sequence [readFile pl | (Playlist pl) <- fs] -printHelp = sequence_ $ map putStrLn $ +printHelp = mapM_ putStrLn [ "Usage:\n pvd [OPTION...] [FILE...]\n" , "Photo Viewer Daemon - a daemon for viewing photos.\n" - , (usageInfo "Available options:" options) + , 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" + [ 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) + (o,n,[] ) -> if Help `elem` o then printHelp >> exitSuccess else return (o, n) + (_,_,errs) -> printHelp >> fail (concatMap (filter ('\n' /=)) errs) initSocket port = withSocketsDo $ do addrinfos <- getAddrInfo @@ -87,57 +88,90 @@ listen sock 5 return sock -socketLoop state sock = do - (connsock, clientaddr) <- accept sock +socketLoop state = do + (connsock, clientaddr) <- accept (stSocket state) forkIO $ processMessages connsock clientaddr - socketLoop state sock + socketLoop state where processMessages connsock clientaddr = do connhdl <- socketToHandle connsock ReadMode hSetBuffering connhdl LineBuffering messages <- hGetContents connhdl - mapM_ runParseCmd (lines messages) + redraw <- fmap or $ mapM (atomically . parseCmd state) (lines messages) + when redraw $ sendExposeEvent (stDpy state) (stWin state) 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 + img <- atomically (fetchImage state) + drawImg (stDpy state) (stWin state) img + X.allocaXEvent $ \e -> X.nextEvent (stDpy state) 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) +cacheLoop state = do + path <- atomically (fetchNextPath state >>= putImgInCache state LoadingImg) + img <- fmap (maybe LoadFailed CachedImg) (loadXImg (stDpy state) path) + atomically (putImgInCache state img path) + cacheLoop state -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 () +fetchImage state = do + idx <- readTVar (stIdx state) + pl <- readTVar (stPlaylist state) + path <- if idx >= 0 && idx < length pl then return (pl !! idx) else retry + cache <- readTVar (stImgCache state) + case lookup path cache of + Just (CachedImg img) -> return img + _ -> retry -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 +fetchNextPath state = do + pl <- readTVar (stPlaylist state) + cache <- readTVar (stImgCache state) + idx <- readTVar (stIdx state) + let paths = take sz (sortBy (comparePaths pl idx) pl) \\ fst (unzip cache) + sz = stImgCacheSize state + if null paths then retry else return (head paths) -gotoIdx s@(State {stPlaylist = pl}) n - | n >= 0 && n < (length pl) = s { stIdx = n } - | otherwise = s +putImgInCache state img path = do + cache <- readTVar (stImgCache state) + pl <- readTVar (stPlaylist state) + idx <- readTVar (stIdx state) + let cache' = (path,img) : filter ((path /=) . fst) cache + scache = sortBy (comparePaths pl idx `on` fst) cache' + writeTVar (stImgCache state) (take (stImgCacheSize state) scache) + return path + +comparePaths playlist idx p1 p2 = case (i1,i2) of + (Nothing, Nothing) -> EQ + (Nothing, Just _) -> GT + (Just _, Nothing) -> LT + (Just n1, Just n2) | idx `elem` [n1,n2] -> comparing abs (n1-idx) (n2-idx) + (Just n1, Just n2) -> comparing abs (n1-idx-1) (n2-idx-1) + where + i1 = elemIndex p1 playlist + i2 = elemIndex p2 playlist + +parseCmd :: State -> String -> STM Bool +parseCmd s@(State {stIdx = idx, stPlaylist = pl}) cmd = case words cmd of + ["next"] -> gotoIdx s (+ 1) + ["prev"] -> gotoIdx s (+ (-1)) + ["first"] -> gotoIdx s (\_ -> 0) + ["last"] -> readTVar pl >>= (\p -> gotoIdx s (\_ -> length p - 1)) + "playlist":"add":imgs -> do + fmap (++ imgs) (readTVar pl) >>= writeTVar pl + return True + "playlist":"replace":imgs -> do + writeTVar idx 0 + writeTVar pl imgs + return True + "playlist":"insert":"0":imgs -> do + p <- readTVar pl + fmap (+ length p) (readTVar idx) >>= writeTVar idx + writeTVar pl (imgs++p) + return True + _ -> return False + +gotoIdx (State {stIdx = idx, stPlaylist = pl}) f = do + i <- readTVar idx + let i' = f i + l <- fmap length (readTVar pl) + when (i' /= i && i' >= 0 && i' < l) (writeTVar idx i') + return (i' /= i) diff --git a/XUtils.hs b/XUtils.hs --- a/XUtils.hs +++ b/XUtils.hs @@ -35,7 +35,7 @@ col <- initColor dpy "#000000" X.createSimpleWindow dpy rootw 0 0 (fromIntegral $ X.wa_width attr) (fromIntegral $ X.wa_height attr) 1 col col -drawImg :: X.Display -> X.Window -> Maybe XImg -> IO () +drawImg :: X.Display -> X.Window -> XImg -> IO () drawImg dpy win ximg = do bgcolor <- initColor dpy "#000000" gc <- X.createGC dpy win @@ -44,12 +44,11 @@ pixmap <- X.createPixmap dpy win winWidth winHeight depth X.setForeground dpy gc bgcolor X.fillRectangle dpy pixmap gc 0 0 winWidth winHeight - for_ ximg $ \xi -> do - let portWidth = fromIntegral (xImgW xi) - portHeight = fromIntegral (xImgH xi) - portX = fromIntegral ((winWidth-portWidth) `div` 2) - portY = fromIntegral ((winHeight-portHeight) `div` 2) - X.putImage dpy pixmap gc (xImg xi) 0 0 portX portY portWidth portHeight + let portWidth = fromIntegral (xImgW ximg) + portHeight = fromIntegral (xImgH ximg) + portX = fromIntegral ((winWidth-portWidth) `div` 2) + portY = fromIntegral ((winHeight-portHeight) `div` 2) + X.putImage dpy pixmap gc (xImg ximg) 0 0 portX portY portWidth portHeight X.copyArea dpy pixmap win gc 0 0 winWidth winHeight 0 0 X.freeGC dpy gc X.freePixmap dpy pixmap diff --git a/pvd.cabal b/pvd.cabal --- a/pvd.cabal +++ b/pvd.cabal @@ -1,5 +1,5 @@ Name: pvd -Version: 1.0.1 +Version: 1.1.0 Synopsis: A photo viewer daemon application with remote controlling abilities. @@ -31,4 +31,4 @@ Executable pvc Main-Is: Pvc.hs - Build-Depends: base >= 4 && < 5, haskell98, network, containers + Build-Depends: base >= 4 && < 5, haskell98, network, containers, stm