{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
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