packages feed

pvd 1.1.0 → 1.1.1

raw patch · 4 files changed

+214/−146 lines, 4 files

Files

Pvd.hs view
@@ -1,65 +1,44 @@-module Main (-  main-) where+module Main (main) where -import Control.Concurrent+import Control.Concurrent (forkIO) import Control.Concurrent.STM-import Control.Monad (when)+import Control.Monad (when, forever, liftM3, liftM) import Data.Maybe (maybe)-import Data.List-import Data.Ord (comparing)-import Data.Function (on)-import Network.Socket import qualified Codec.Image.DevIL as IL (ilInit) import qualified Graphics.X11.Xlib as X import qualified Graphics.X11.Xlib.Extras as X+import qualified XUtils as X+import System.Console.GetOpt import System.Exit (exitSuccess)-import System.IO import System (getArgs)-import System.Console.GetOpt-import XUtils--type Index = TVar Int-type Playlist = TVar [String]-type Cache = TVar [(String, CachedImg)]--data CachedImg = CachedImg XImg | LoadingImg | LoadFailed--data State = State {-  stIdx :: Index,-  stPlaylist :: Playlist,-  stDpy :: X.Display,-  stWin :: X.Window,-  stImgCache :: Cache,-  stImgCacheSize :: Int,-  stSocket :: Socket-}+import PvdSocket (initSocket, handleClient)+import PvdMonad  data Flag =   Port String | CacheSize Int | Playlist String | Help     deriving (Eq)  main = do+  conf <- initApp+  forkIO $ forever $ updateCache conf+  forkIO $ forever $ handleEvent conf+  forever $ handleClient conf++initApp = do   args <- getArgs-  (flags, files1) <- parseOptions args-  files2 <- readPlaylist flags+  (flags, fs1) <- parseOptions args+  fs2 <- fmap (concatMap words) $ sequence [readFile p | (Playlist p) <- flags]   let cacheSize = last [c | CacheSize c <- CacheSize 15 : flags]       port = last [p | Port p <- Port "4245" : flags]+      playlist = fs1++fs2   IL.ilInit-  (dpy,win) <- initX+  (dpy,win) <- X.initX   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-  }-  forkIO $ cacheLoop state-  forkIO $ eventLoop state-  socketLoop state+  initPvd playlist dpy win cacheSize socket -readPlaylist fs = fmap (concatMap words) $ sequence [readFile pl | (Playlist pl) <- fs]+parseOptions argv = case getOpt Permute options argv of+  (o,n,[]  ) -> if Help `elem` o then printHelp >> exitSuccess else return (o, n)+  (_,_,errs) -> printHelp >> fail (concatMap (filter ('\n' /=)) errs)  printHelp = mapM_ putStrLn   [ "Usage:\n  pvd [OPTION...] [FILE...]\n"@@ -74,104 +53,15 @@   , Option "l" ["playlist"] (ReqArg Playlist "PLAYLIST") "playlist file"   ] -parseOptions argv = case getOpt Permute options argv of-  (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-    (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 = do-  (connsock, clientaddr) <- accept (stSocket state)-  forkIO $ processMessages connsock clientaddr-  socketLoop state-    where-      processMessages connsock clientaddr = do-        connhdl <- socketToHandle connsock ReadMode-        hSetBuffering connhdl LineBuffering-        messages <- hGetContents connhdl-        redraw <- fmap or $ mapM (atomically . parseCmd state) (lines messages)-        when redraw $ sendExposeEvent (stDpy state) (stWin state)-        hClose connhdl--eventLoop state = do-  img <- atomically (fetchImage state)-  drawImg (stDpy state) (stWin state) img-  X.allocaXEvent $ \e -> X.nextEvent (stDpy state) e-  eventLoop state--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--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--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)--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+handleEvent conf = do+  (img, dpy, win) <- runPvd conf (liftM3 (,,) currentImage getDpy getWin)+  X.drawImg dpy win img+  X.allocaXEvent $ \e -> X.nextEvent dpy e -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)+updateCache conf = do+  (path, dpy) <- runPvd conf $ do+    path <- fetchNextPath+    putImgInCache LoadingImg path+    liftM ((,) path) getDpy+  img <- fmap (maybe LoadFailed CachedImg) (X.loadXImg dpy path)+  runPvd conf (putImgInCache img path)
+ PvdMonad.hs view
@@ -0,0 +1,133 @@+module PvdMonad (+  Pvd,+  PvdConf,+  CachedImg(..),+  initPvd,+  runPvd,+  getSocket,+  currentImage,+  fetchNextPath,+  putImgInCache,+  modPlaylist,+  getPlaylist,+  setPlaylist,+  getWin,+  getDpy,+  modIdx,+  getIdx,+  setIdx+) where++import Control.Concurrent.STM+import Control.Monad.Reader+import Control.Monad (liftM)+import Data.Ord (comparing)+import Data.Function (on)+import Data.List ((\\), sortBy, elemIndex)+import Graphics.X11.Xlib (Display, Window)+import Network.Socket (Socket)+import XUtils (XImg)++data PvdConf = PvdConf {+  cIdx :: TVar Int,+  cPlaylist :: TVar [String],+  cDpy :: Display,+  cWin :: Window,+  cImgCache :: TVar [(String, CachedImg)],+  cImgCacheSize :: Int,+  cSocket :: Socket+}++data CachedImg = CachedImg XImg | LoadingImg | LoadFailed++type Pvd = ReaderT PvdConf STM++runPvd :: PvdConf -> Pvd a -> IO a+runPvd conf pvd = atomically $ runReaderT pvd conf++initPvd playlist dpy win cacheSize socket = do+  cache <- newTVarIO []+  idx <- newTVarIO 0+  pl <- newTVarIO playlist+  let conf = PvdConf {+    cIdx = idx, cPlaylist = pl, cDpy = dpy, cWin = win,+    cImgCache = cache, cImgCacheSize = cacheSize, cSocket = socket+  }+  return conf++readT :: (PvdConf -> TVar a) -> Pvd a+readT f = liftM f ask >>= (lift . readTVar)++writeT :: (PvdConf -> TVar a) -> a -> Pvd ()+writeT f x = liftM f ask >>= (lift . flip writeTVar x)++getSocket :: Pvd Socket+getSocket = liftM cSocket ask++getDpy :: Pvd Display+getDpy = liftM cDpy ask++getWin :: Pvd Window+getWin = liftM cWin ask++getPlaylist :: Pvd [String]+getPlaylist = readT cPlaylist++setPlaylist :: [String] -> Pvd Bool+setPlaylist p = do+  p0 <- readT cPlaylist+  writeT cPlaylist p+  return (p /= p0)++getIdx :: Pvd Int+getIdx = readT cIdx++setIdx :: Int -> Pvd Bool+setIdx i = do+  i0 <- readT cIdx+  writeT cIdx i+  return (i /= i0)++currentImage = do+  idx <- getIdx+  pl <- getPlaylist+  path <- if idx >= 0 && idx < length pl then return (pl !! idx) else lift retry+  cache <- readT cImgCache+  case lookup path cache of+    Just (CachedImg img) -> return img+    _ -> lift retry++fetchNextPath = do+  pl <- getPlaylist+  cache <- readT cImgCache+  idx <- getIdx+  sz <- liftM cImgCacheSize ask+  let paths = take sz (sortBy (comparePaths pl idx) pl) \\ fst (unzip cache)+  if null paths then lift retry else return (head paths)++putImgInCache img path = do+  cache <- readT cImgCache+  pl <- getPlaylist+  idx <- getIdx+  cacheSize <- liftM cImgCacheSize ask+  let cache' = (path,img) : filter ((path /=) . fst) cache+      scache = sortBy (comparePaths pl idx `on` fst) cache'+  writeT cImgCache (take cacheSize 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++modIdx f = do+  i <- getIdx+  l <- liftM length getPlaylist+  setIdx $ max 0 (min (l-1) (f (l,i)))++modPlaylist f = liftM f getPlaylist >>= setPlaylist
+ PvdSocket.hs view
@@ -0,0 +1,45 @@+module PvdSocket (+  initSocket,+  handleClient+) where++import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Monad (liftM, liftM2, liftM3, when)+import Network.Socket+import qualified System.IO as IO+import qualified XUtils as X+import PvdMonad++handleClient conf = do+  (socket,dpy,win) <- runPvd conf (liftM3 (,,) getSocket getDpy getWin)+  accept socket >>= forkIO . uncurry (processMessages dpy win)+  where processMessages dpy win connsock clientaddr = do+          connhdl <- socketToHandle connsock IO.ReadMode+          IO.hSetBuffering connhdl IO.LineBuffering+          messages <- IO.hGetContents connhdl+          redraw <- fmap or $ mapM (runPvd conf . handleCmd) (lines messages)+          IO.hClose connhdl+          when redraw $ X.sendExposeEvent dpy win++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++handleCmd :: String -> Pvd Bool+handleCmd cmd = case words cmd of+  ["next"] -> modIdx $ (1 +) . snd+  ["prev"] -> modIdx $ (-1 +) . snd+  ["last"] -> modIdx $ (-1 +) . fst+  ["first"] -> modIdx $ \_ -> 0+  "playlist":"add":imgs -> modPlaylist (++ imgs)+  "playlist":"replace":imgs -> liftM2 (||) (setIdx 0) (setPlaylist imgs)+  "playlist":"insert":"0":imgs ->+    liftM2 (||) (modPlaylist (imgs ++)) (modIdx $ (length imgs +) . snd)+  _ -> return False
pvd.cabal view
@@ -1,5 +1,5 @@ Name:                pvd-Version:             1.1.0+Version:             1.1.1  Synopsis:            A photo viewer daemon application with remote controlling abilities. @@ -10,7 +10,7 @@ License-file:        LICENSE Author:              Rickard Nilsson Maintainer:          rickard.nilsson@telia.com-Copyright:           (c) 2010, Rickard Nilsson+Copyright:           (c) 2011, Rickard Nilsson Category:            Image Viewer Build-type:          Simple Extra-source-files:  README@@ -19,9 +19,9 @@ Executable pvd   Main-Is:         Pvd.hs   Build-Depends:   base >= 4 && < 5, array, X11, Codec-Image-DevIL, network, mtl-  Other-Modules:   Codec.Image.DevIL.Extras, XUtils+  Other-Modules:   Codec.Image.DevIL.Extras, XUtils, PvdSocket, PvdMonad   Build-tools:     hsc2hs-  Extensions:      ForeignFunctionInterface, CPP+  Extensions:      ForeignFunctionInterface, CPP, GeneralizedNewtypeDeriving   Ghc-Options:     -threaded   Extra-Libraries: IL, pthread   if os(windows)