pvd 1.0.1 → 1.1.0
raw patch · 4 files changed
+129/−96 lines, 4 filesdep +stm
Dependencies added: stm
Files
Pvc.hs view
@@ -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 = "<CMD>\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"
Pvd.hs view
@@ -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)
XUtils.hs view
@@ -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
pvd.cabal view
@@ -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