keera-hails-mvc-solutions-gtk 0.0.3.3 → 0.0.3.4

raw patch · 2 files changed

+78/−2 lines, 2 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• keera-hails-mvc-solutions-gtk.cabal +2/−2
• src/Hails/Graphics/UI/Gtk/Simplify/UpdateCheck.hs +76/−0

@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.0.3.3+Version:             0.0.3.4  -- A short (one-line) description of the package. Synopsis:            Haskell on Gtk rails - Common solutions to recurrent problems in Gtk applications@@ -62,7 +62,7 @@                  , Hails.Graphics.UI.Gtk.Simplify.AboutDialog                  , Hails.Graphics.UI.Gtk.Simplify.Logger                  , Hails.Graphics.UI.Gtk.Simplify.RootLogger-                 -- , Hails.Graphics.UI.Gtk.Simplify.UpdateCheck+                 , Hails.Graphics.UI.Gtk.Simplify.UpdateCheck      -- Packages needed in order to build this package.   Build-depends: base >= 4 && < 5

@@ -0,0 +1,76 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+module Hails.Graphics.UI.Gtk.Simplify.UpdateCheck where++-- External Imports+import Control.Concurrent+import Control.Exception as E+import Control.Monad+import Data.Maybe+import Hails.MVC.View+import Hails.MVC.View.GtkView+-- import Graphics.UI.Gtk.GenericView+import Hails.MVC.GenericCombinedEnvironment+import Network.HTTP+import Network.URI++-- Internal Imports+import Data.ExtraVersion+import Data.ReactiveValue+import Hails.MVC.Model.ProtectedModel.UpdatableModel++installHandlers :: (GtkGUI a, UpdatableBasicModel b, UpdateNotifiableEvent c+                   )+                => CEnv a b c+                -> (ViewElementAccessorIO (GtkView a) (ReactiveFieldActivatable IO))+                -> IO ()+installHandlers cenv mF = do+  let vw = view cenv+  mn <- mF vw :: IO (ReactiveFieldActivatable IO)+  mn `reactiveValueOnCanRead` onViewAsync vw (condition cenv)++condition :: (GtkGUI a, UpdatableBasicModel b, UpdateNotifiableEvent c)+          => CEnv a b c+          -> IO ()+condition cenv = void $+  forkIO $ E.handle (constantlyHandle (return ())) $ do+    let pm = model cenv+    url <- getUpdateURI pm+    v   <- (netRead url) :: IO (Either String Version)+    case v of+      (Left  _) -> return ()+      (Right s) -> setMaxVersionAvail pm s++netRead :: Read a => String -> IO (Either String a)+netRead url = do+  v <- downloadURL url+  case v of+   (Left s)  -> return (Left s)+   (Right s) -> E.handle (constantlyHandle (return $ Left "Format error"))+                         (return $ Right $ read s)++-- FIXME: use anyway and create ignoringExceptions+constantlyHandle :: a -> E.SomeException -> a+constantlyHandle a _ = a++{- | Download a URL.  (Left errorMessage) if an error,+ - (Right doc) if success.+ -}+downloadURL :: String -> IO (Either String String)+downloadURL url =+    do resp <- simpleHTTP request+       case resp of+         Left x -> return $ Left ("Error connecting: " ++ show x)+         Right r ->+             case rspCode r of+               (2,_,_) -> return $ Right (rspBody r)+               (3,_,_) -> -- A HTTP redirect+                 case findHeader HdrLocation r of+                   Nothing -> return $ Left (show r)+                   Just url' -> downloadURL url'+               _ -> return $ Left (show r)+    where request = Request {rqURI = uri,+                             rqMethod = GET,+                             rqHeaders = [],+                             rqBody = ""}+          uri = fromJust $ parseURI url